/* File: emuloop.c
** Author(s): Warren, Swift, Xu, Sagonas, Johnson
** Contact: xsb-contact@cs.sunysb.edu
**
** Copyright (C) The Research Foundation of SUNY, 1986, 1993-1998
** Copyright (C) ECRC, Germany, 1990
**
** XSB is free software; you can redistribute it and/or modify it under the
** terms of the GNU Library General Public License as published by the Free
** Software Foundation; either version 2 of the License, or (at your option)
** any later version.
**
** XSB is distributed in the hope that it will be useful, but WITHOUT ANY
** WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
** FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for
** more details.
**
** You should have received a copy of the GNU Library General Public License
** along with XSB; if not, write to the Free Software Foundation,
** Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
**
** $Id: emuloop.c,v 1.95 2003/03/14 18:54:29 dwarren Exp $
**
*/
#include "xsb_config.h"
#include "xsb_debug.h"
#include <stdio.h>
#include <stdlib.h>
#include <signal.h>
#include <string.h>
#ifdef FOREIGN
#ifndef SOLARIS
#ifndef FOREIGN_WIN32
#include <sys/un.h>
#endif
#endif
#endif
#include "auxlry.h"
#include "cell_xsb.h"
#include "register.h"
#include "error_xsb.h"
#include "inst_xsb.h"
#include "psc_xsb.h"
#include "deref.h"
#include "memory_xsb.h"
#include "heap_xsb.h"
#include "sig_xsb.h"
#include "emudef.h"
#include "loader_xsb.h"
#include "binding.h"
#include "flags_xsb.h"
#include "trie_internals.h"
#include "choice.h"
#include "sw_envs.h"
#include "macro_xsb.h"
#include "tables.h"
#include "subinst.h"
#include "scc_xsb.h"
#include "subp.h"
#include "tr_utils.h"
#include "cut_xsb.h"
#include "export.h"
#include "orient_xsb.h"
#include "io_builtins_xsb.h"
#include "unify_xsb.h"
#include "emuloop_aux.h"
#include "remove_unf.h"
#include "debug_xsb.h"
#include "hash_xsb.h"
/*
* Variable ans_var_pos_reg is a pointer to substitution factor of an
* answer in the heap. It is used and set in function
* variant_answer_search(). The name of this variable is from VarPosReg, a
* variable used in variant_call_search() to save the substitution factor
* of the call.
*/
CPtr ans_var_pos_reg;
/*----------------------------------------------------------------------*/
#include "tr_delay.h"
#include "tr_code_xsb_i.h"
/*----------------------------------------------------------------------*/
/* indirect threading-related stuff */
#ifdef DEBUG_VM
#define XSB_Debug_Instr \
if (flags[PIL_TRACE]) { \
debug_inst(lpcreg, ereg); \
} \
xctr++;
#else
#define XSB_Debug_Instr
#endif
#ifdef PROFILE
#define XSB_Profile_Instr \
if (flags[PROFFLAG]) { \
inst_table[(int) *(lpcreg)][sizeof(Cell)+1] \
= inst_table[(int) *(lpcreg)][sizeof(Cell)+1] + 1; \
if (flags[PROFFLAG] > 1 && (int) *lpcreg == builtin) \
builtin_table[(int) *(lpcreg+3)][1] = \
builtin_table[(int) *(lpcreg+3)][1] + 1; \
}
#else
#define XSB_Profile_Instr
#endif
/* lfcastro: with INSN_BLOCKS, we use a block for each WAM instruction,
and define temporary variables locally; otherwise, temp variables are
global to the emuloop function */
#ifdef INSN_BLOCKS
#define Def1op register Cell op1;
#define Def2ops register Cell op1, op2;
#define Def3ops register Cell op1,op2; register CPtr op3;
#define DefOps13 register Cell op1; register CPtr op3;
#define DefGlobOps
#else
#define Def1op
#define Def2ops
#define Def3ops
#define DefOps13
#define DefGlobOps register Cell op1,op2; register CPtr op3;
#endif
/* lfcastro: with JUMPTABLE_EMULOOP, we use GCC's first-order labels to
create a jumptable for the WAM instructions of emuloop(); otherwise
a switch statement is used. */
#ifdef JUMPTABLE_EMULOOP
static void *instr_addr[256];
#define XSB_End_Instr() \
XSB_Debug_Instr \
XSB_Profile_Instr \
goto *instr_addr[(byte)*lpcreg]; \
}
#define XSB_Next_Instr() \
do { \
XSB_Debug_Instr \
XSB_Profile_Instr \
goto *instr_addr[(byte)*lpcreg]; \
} while(0)
#define XSB_Start_Instr_Chained(Instr,Label) \
Label:
#define XSB_Start_Instr(Instr,Label) \
Label: {
#else /* no threading */
#define XSB_Next_Instr() goto contcase
#define XSB_End_Instr() goto contcase; }
#define XSB_Start_Instr_Chained(Instr,Label) \
case Instr:
#define XSB_Start_Instr(Instr,Label) \
case Instr: {
#endif
/*----------------------------------------------------------------------*/
#define get_axx (lpcreg[1])
#define get_vxx (ereg-(Cell)lpcreg[1])
#define get_rxx (rreg+lpcreg[1])
#define get_xax (lpcreg[2])
#define get_xvx (ereg-(Cell)lpcreg[2])
#define get_xrx (rreg+lpcreg[2])
#define get_xxa (lpcreg[3])
#define get_xxv (ereg-(Cell)lpcreg[3])
#define get_xxr (rreg+lpcreg[3])
#define get_xxxl (*(CPtr)(lpcreg+sizeof(Cell)))
#define get_xxxs (*(CPtr)(lpcreg+sizeof(Cell)))
#define get_xxxc (*(CPtr)(lpcreg+sizeof(Cell)))
#define get_xxxn (*(CPtr)(lpcreg+sizeof(Cell)))
#define get_xxxg (*(CPtr)(lpcreg+sizeof(Cell)))
#define get_xxxi (*(CPtr)(lpcreg+sizeof(Cell)))
#define get_xxxf (*(CPtr)(lpcreg+sizeof(Cell)))
#define get_xxxxi (*(CPtr)(lpcreg+sizeof(Cell)*2))
#define get_xxxxl (*(CPtr)(lpcreg+sizeof(Cell)*2))
#define Op1(Expr) op1 = (Cell)Expr
#define Op2(Expr) op2 = (Cell)Expr
#define Op3(Expr) op3 = (CPtr)Expr
#define Register(Expr) (cell(Expr))
#define Variable(Expr) (cell(Expr))
#define size_none 0
#define size_xxx 1
#define size_xxxX 2
#define size_xxxXX 3
#define ADVANCE_PC(InstrSize) (lpcreg += InstrSize*sizeof(Cell))
/* Be sure that flag only has the following two values. */
#define WRITE 1
#define READFLAG 0
#ifdef USE_BP_LPCREG
#define POST_LPCREG_DECL asm ("bp")
#else
#define POST_LPCREG_DECL
#endif
/*----------------------------------------------------------------------*/
/* The following macros work for all CPs. Make sure this remains */
/* the case... */
/*----------------------------------------------------------------------*/
#define Fail1 lpcreg = cp_pcreg(breg);
#define restore_trail_condition_registers(breg) \
if (*breg != (Cell) &check_complete_inst) { \
ebreg = cp_ebreg(breg); \
hbreg = cp_hreg(breg); \
}
/*----------------------------------------------------------------------*/
extern int builtin_call(byte), unifunc_call(int, CPtr);
extern Cell builtin_table[BUILTIN_TBL_SZ][2];
extern Pair build_call(Psc);
#ifdef DEBUG_VM
extern void debug_inst(byte *, CPtr);
#endif
/**static int (*dyn_pred)(); unused-remove soon**/
xsbBool neg_delay;
int xwammode, level_num;
#ifdef DEBUG_VM
int xctr;
#endif
/*----------------------------------------------------------------------*/
#include "schedrev_xsb_i.h"
#ifndef LOCAL_EVAL
#include "wfs_xsb_i.h"
#endif
#include "complete_local.h"
/*----------------------------------------------------------------------*/
/* place for a meaningful message when segfault is detected */
char *xsb_default_segfault_msg =
"\n++Memory violation occurred during evaluation.\n++Please report this problem using the XSB bug tracking system accessible from\n++\t http://sourceforge.net/projects/xsb\n++Please supply the steps necessary to reproduce the bug.\n";
char *xsb_segfault_message;
jmp_buf xsb_abort_fallback_environment;
/*======================================================================*/
/* the main emulator loop. */
/*======================================================================*/
/*
* The WAM instructions are aligned with word (4 bytes on 32-bit machines,
* or 8-byte on 64-bit machines), the shortest instructions (like fail)
* take one word, and the longest ones take three words (like
* switchon3bound). If an instruction takes more than one word, then the
* 2nd (or 3rd) word always contains an operand that takes one word. The
* one-word operands can be (see file emu/inst_xsb.h):
*
* L - label
* S - structure symbol
* C - constant symbol
* N - number
* G - string
* I - 2nd & 3rd arguments of switchonbound
* F - floating point number
*
* The opcode of all instructions takes the first byte in the first word.
* The rest 3 bytes contain operands that needs only one byte. These
* one-byte operands can be:
*
* P - pad, not used
* A - one byte number
* V - variable offset
* R - register number
*
* (In 64-bit machines there are 4 bytes of extra padding space for each
* instruction)
*/
static int emuloop(byte *startaddr)
{
register CPtr rreg;
register byte *lpcreg POST_LPCREG_DECL;
DefGlobOps
byte flag = READFLAG; /* read/write mode flag */
int restore_type; /* 0 for retry restore; 1 for trust restore */
#if (defined(GC) && defined(GC_TEST))
/* Used only in the garbage collection test; does not affect emulator o/w */
#define GC_INFERENCES 66 /* make sure the garbage collection test is hard */
static int infcounter = 0;
#endif
xsb_segfault_message = xsb_default_segfault_msg;
rreg = reg; /* for SUN */
#ifdef JUMPTABLE_EMULOOP
#define XSB_INST(INum,Instr,Label,d1,d2,d3,d4) \
instr_addr[INum] = && Label
#include "xsb_inst_list.h"
#endif
if ((lpcreg = (byte *) setjmp(xsb_abort_fallback_environment))) {
/*
* Short circuit untrailing to avoid possible seg faults in
* switch_envs.
*/
trreg = cp_trreg(breg);
/* Restore the default signal handling */
signal(SIGSEGV, xsb_default_segfault_handler);
} else
lpcreg = startaddr; /* first instruction of entire engine */
#ifdef JUMPTABLE_EMULOOP
XSB_Next_Instr();
#else
contcase: /* the main loop */
#ifdef DEBUG_VM
if (flags[PIL_TRACE]) debug_inst(lpcreg, ereg);
xctr++;
#endif
#ifdef PROFILE
if (flags[PROFFLAG]) {
inst_table[(int) *(lpcreg)][sizeof(Cell)+1]
= inst_table[(int) *(lpcreg)][sizeof(Cell)+1] + 1;
if (flags[PROFFLAG] > 1 && (int) *lpcreg == builtin)
builtin_table[(int) *(lpcreg+3)][1] =
builtin_table[(int) *(lpcreg+3)][1] + 1;
}
#endif
switch (*lpcreg) {
#endif
XSB_Start_Instr(getpvar,_getpvar) /* PVR */
Def2ops
Op1(Variable(get_xvx));
Op2(Register(get_xxr));
ADVANCE_PC(size_xxx);
/* trailing is needed here because this instruction can also be
generated *after* the occurrence of the first call - kostis */
bind_copy((CPtr)op1, op2); /* In WAM bld_copy() */
XSB_End_Instr()
XSB_Start_Instr(getpval,_getpval) /* PVR */
Def2ops
Op1(Variable(get_xvx));
Op2(Register(get_xxr));
ADVANCE_PC(size_xxx);
unify_xsb(_getpval);
XSB_End_Instr()
XSB_Start_Instr(getstrv,_getstrv) /* PPV-S */
Def2ops
Op1(Variable(get_xxv));
Op2(get_xxxs);
ADVANCE_PC(size_xxxX);
nunify_with_str(op1,op2);
XSB_End_Instr()
XSB_Start_Instr(gettval,_gettval) /* PRR */
Def2ops
Op1(Register(get_xrx));
Op2(Register(get_xxr));
ADVANCE_PC(size_xxx);
unify_xsb(_gettval);
XSB_End_Instr()
XSB_Start_Instr(getcon,_getcon) /* PPR-C */
Def2ops
Op1(Register(get_xxr));
Op2(get_xxxc);
ADVANCE_PC(size_xxxX);
nunify_with_con(op1,op2);
XSB_End_Instr()
XSB_Start_Instr(getnil,_getnil) /* PPR */
Def1op
Op1(Register(get_xxr));
ADVANCE_PC(size_xxx);
nunify_with_nil(op1);
XSB_End_Instr()
XSB_Start_Instr(getstr,_getstr) /* PPR-S */
Def2ops
Op1(Register(get_xxr));
Op2(get_xxxs);
ADVANCE_PC(size_xxxX);
nunify_with_str(op1,op2);
XSB_End_Instr()
XSB_Start_Instr(getlist,_getlist) /* PPR */
Def1op
Op1(Register(get_xxr));
ADVANCE_PC(size_xxx);
nunify_with_list_sym(op1);
XSB_End_Instr()
XSB_Start_Instr(getattv,_getattv) /* PPR */
Def1op
Op1(Register(get_xxr));
ADVANCE_PC(size_xxx);
nunify_with_attv(op1);
XSB_End_Instr()
/* TLS: Need trailing here: for a full explanation, see "A Note on
Trailing in the SLGWAM on my web page. */
XSB_Start_Instr(unipvar,_unipvar) /* PPV */
Def1op
Op1(get_xxv);
ADVANCE_PC(size_xxx);
if (!flag) { /* if (flag == READ) */
/* also introduce trailing here - bmd & kostis
was: bld_copy((CPtr)op1, *(sreg++)); */
bind_copy((CPtr)op1, *(sreg));
sreg++;
} else {
bind_ref((CPtr)op1, hreg);
new_heap_free(hreg);
}
XSB_End_Instr()
XSB_Start_Instr(unipval,_unipval) /* PPV */
Def2ops
Op1(Variable(get_xxv));
ADVANCE_PC(size_xxx);
if (flag) { /* if (flag == WRITE) */
nbldval(op1);
}
else {
op2 = *(sreg++);
unify_xsb(_unipval);
}
XSB_End_Instr()
XSB_Start_Instr(unitvar,_unitvar) /* PPR */
Def1op
Op1(get_xxr);
ADVANCE_PC(size_xxx);
if (!flag) { /* if (flag == READ) */
bld_copy((CPtr)op1, *(sreg++));
}
else {
bld_ref((CPtr)op1, hreg);
new_heap_free(hreg);
}
XSB_End_Instr()
XSB_Start_Instr(unitval,_unitval) /* PPR */
Def2ops
Op1(Register(get_xxr));
ADVANCE_PC(size_xxx);
if (flag) { /* if (flag == WRITE) */
nbldval(op1);
XSB_Next_Instr();
}
else {
op2 = *(sreg++);
unify_xsb(_unitval);
}
XSB_End_Instr()
XSB_Start_Instr(unicon,_unicon) /* PPP-C */
Def2ops
Op2(get_xxxc);
ADVANCE_PC(size_xxxX);
if (flag) { /* if (flag == WRITE) */
new_heap_string(hreg, (char *)op2);
}
else {
/* op2 already set */
op1 = *(sreg++);
nunify_with_con(op1,op2);
}
XSB_End_Instr()
XSB_Start_Instr(uninil,_uninil) /* PPP */
Def1op
ADVANCE_PC(size_xxx);
if (flag) { /* if (flag == WRITE) */
new_heap_nil(hreg);
}
else {
op1 = *(sreg++);
nunify_with_nil(op1);
}
XSB_End_Instr()
XSB_Start_Instr(getnumcon,_getnumcon) /* PPR-B */
Def2ops
Op1(Register(get_xxr));
Op2(get_xxxn);
ADVANCE_PC(size_xxxX);
nunify_with_num(op1,op2);
XSB_End_Instr()
XSB_Start_Instr(getfloat,_getfloat) /* PPR-F */
Def2ops
Op1(Register(get_xxr));
Op2(get_xxxn);
ADVANCE_PC(size_xxxX);
nunify_with_float(op1,op2);
XSB_End_Instr()
XSB_Start_Instr(putnumcon,_putnumcon) /* PPR-B */
Def2ops
Op1(get_xxr);
/* Op2(get_xxxn); */
op2 = *(pw)(lpcreg+sizeof(Cell));
ADVANCE_PC(size_xxxX);
bld_int_tagged((CPtr)op1, op2);
XSB_End_Instr()
XSB_Start_Instr(putfloat,_putfloat) /* PPR-F */
Def2ops
Op1(get_xxr);
Op2(get_xxxn);
ADVANCE_PC(size_xxxX);
bld_float_tagged((CPtr)op1, op2);
XSB_End_Instr()
XSB_Start_Instr(putpvar,_putpvar) /* PVR */
Def2ops
Op1(get_xvx);
Op2(get_xxr);
ADVANCE_PC(size_xxx);
bld_free((CPtr)op1);
bld_ref((CPtr)op2, (CPtr)op1);
XSB_End_Instr()
XSB_Start_Instr(putpval,_putpval) /* PVR */
DefOps13
Op1(get_xvx);
Op3(get_xxr);
ADVANCE_PC(size_xxx);
bld_copy(op3, *((CPtr)op1));
XSB_End_Instr()
XSB_Start_Instr(puttvar,_puttvar) /* PRR */
Def2ops
Op1(get_xrx);
Op2(get_xxr);
ADVANCE_PC(size_xxx);
bld_ref((CPtr)op1, hreg);
bld_ref((CPtr)op2, hreg);
new_heap_free(hreg);
XSB_End_Instr()
/* TLS: Need trailing here: for a full explanation, see "A Note on
Trailing in the SLGWAM on my web page. */
XSB_Start_Instr(putstrv,_putstrv) /* PPV-S */
Def2ops
Op1(get_xxv);
Op2(get_xxxs);
ADVANCE_PC(size_xxxX);
bind_cs((CPtr)op1, (Pair)hreg);
new_heap_functor(hreg, (Psc)op2);
XSB_End_Instr()
XSB_Start_Instr(putcon,_putcon) /* PPR-C */
Def2ops
Op1(get_xxr);
Op2(get_xxxc);
ADVANCE_PC(size_xxxX);
bld_string((CPtr)op1, (char *)op2);
XSB_End_Instr()
XSB_Start_Instr(putnil,_putnil) /* PPR */
Def1op
Op1(get_xxr);
ADVANCE_PC(size_xxx);
bld_nil((CPtr)op1);
XSB_End_Instr()
/* doc tls -- differs from putstrv since it pulls from a register.
Thus the variable is already initialized. */
XSB_Start_Instr(putstr,_putstr) /* PPR-S */
Def2ops
Op1(get_xxr);
Op2(get_xxxs);
ADVANCE_PC(size_xxxX);
bld_cs((CPtr)op1, (Pair)hreg);
new_heap_functor(hreg, (Psc)op2);
XSB_End_Instr()
XSB_Start_Instr(putlist,_putlist) /* PPR */
Def1op
Op1(get_xxr);
ADVANCE_PC(size_xxx);
bld_list((CPtr)op1, hreg);
XSB_End_Instr()
XSB_Start_Instr(putattv,_putattv) /* PPR */
Def1op
Op1(get_xxr);
ADVANCE_PC(size_xxx);
bld_attv((CPtr)op1, hreg);
new_heap_free(hreg);
XSB_End_Instr()
/* TLS: Need trailing here: for a full explanation, see "A Note on
Trailing in the SLGWAM on my web page. */
XSB_Start_Instr(bldpvar,_bldpvar) /* PPV */
Def1op
Op1(get_xxv);
ADVANCE_PC(size_xxx);
bind_ref((CPtr)op1, hreg); /* trailing is needed: if o/w see ai_tests */
new_heap_free(hreg);
XSB_End_Instr()
XSB_Start_Instr(bldpval,_bldpval) /* PPV */
Def1op
Op1(Variable(get_xxv));
ADVANCE_PC(size_xxx);
nbldval(op1);
XSB_End_Instr()
XSB_Start_Instr(bldtvar,_bldtvar) /* PPR */
Def1op
Op1(get_xxr);
ADVANCE_PC(size_xxx);
bld_ref((CPtr)op1, hreg);
new_heap_free(hreg);
XSB_End_Instr()
XSB_Start_Instr(bldtval,_bldtval) /* PPR */
Def1op
Op1(Register(get_xxr));
ADVANCE_PC(size_xxx);
nbldval(op1);
XSB_End_Instr()
XSB_Start_Instr(bldcon,_bldcon) /* PPP-C */
Def1op
Op1(get_xxxc);
ADVANCE_PC(size_xxxX);
new_heap_string(hreg, (char *)op1);
XSB_End_Instr()
XSB_Start_Instr(bldnil,_bldnil) /* PPP */
ADVANCE_PC(size_xxx);
new_heap_nil(hreg);
XSB_End_Instr()
XSB_Start_Instr(getlist_tvar_tvar,_getlist_tvar_tvar) /* RRR */
Def3ops
Op1(Register(get_rxx));
Op2(get_xrx);
Op3(get_xxr);
ADVANCE_PC(size_xxx);
XSB_Deref(op1);
if (islist(op1)) {
sreg = clref_val(op1);
op1 = (Cell)op2;
bld_ref((CPtr)op1, *(sreg));
op1 = (Cell)op3;
bld_ref((CPtr)op1, *(sreg+1));
} else if (isref(op1)) {
bind_list((CPtr)(op1), hreg);
op1 = (Cell)op2;
bld_ref((CPtr)op1, hreg);
new_heap_free(hreg);
op1 = (Cell)op3;
bld_ref((CPtr)op1, hreg);
new_heap_free(hreg);
} else if (isattv(op1)) {
attv_dbgmsg(">>>> getlist_tvar_tvar: ATTV interrupt needed\n");
add_interrupt(op1, makelist(hreg));
op1 = (Cell)op2;
bld_ref((CPtr)op1, hreg);
new_heap_free(hreg);
op1 = (Cell)op3;
bld_ref((CPtr)op1, hreg);
new_heap_free(hreg);
}
else Fail1;
XSB_End_Instr() /* end getlist_tvar_tvar */
XSB_Start_Instr(uninumcon,_uninumcon) /* PPP-B */
Def2ops
Op2(get_xxxn); /* num in op2 */
ADVANCE_PC(size_xxxX);
if (flag) { /* if (flag == WRITE) */
new_heap_num(hreg, (Integer)op2);
}
else { /* op2 set */
op1 = *(sreg++);
nunify_with_num(op1,op2);
}
XSB_End_Instr()
XSB_Start_Instr(unifloat,_unifloat) /* PPPF */
Def2ops
Op2(get_xxxf); /* num in op2 */
ADVANCE_PC(size_xxxX);
if (flag) { /* if (flag == WRITE) */
new_heap_float(hreg, op2);
}
else { /* op2 set */
op1 = cell(sreg++);
nunify_with_float(op1,op2);
}
XSB_End_Instr()
XSB_Start_Instr(bldnumcon,_bldnumcon) /* PPP-B */
Def1op
Op1(get_xxxn); /* num to op2 */
ADVANCE_PC(size_xxxX);
new_heap_num(hreg, (Integer)op1);
XSB_End_Instr()
XSB_Start_Instr(bldfloat,_bldfloat) /* PPP-F */
Def1op
Op1(get_xxxf); /* num to op2 */
ADVANCE_PC(size_xxxX);
new_heap_float(hreg, op1);
XSB_End_Instr()
XSB_Start_Instr(trymeelse,_trymeelse) /* PPA-L */
Def2ops
Op1(get_xxa);
Op2(get_xxxl);
#if 0
{
Psc mypsc = *(CPtr)(cpreg-4);
if (mypsc)
if (get_type(mypsc) == T_PRED) {
fprintf(stddbg,"creating_cp(trymeelse(%s/%d), %p).\n",
get_name(mypsc), get_arity(mypsc), breg);
}
}
#endif
ADVANCE_PC(size_xxxX);
SUBTRYME
XSB_End_Instr()
XSB_Start_Instr(retrymeelse,_retrymeelse) /* PPA-L */
Def1op
Op1(get_xxa);
cp_pcreg(breg) = (byte *)get_xxxl;
restore_type = 0;
ADVANCE_PC(size_xxxX);
RESTORE_SUB
XSB_End_Instr()
XSB_Start_Instr(trustmeelsefail,_trustmeelsefail) /* PPA */
Def1op
Op1(get_xxa);
restore_type = 1;
ADVANCE_PC(size_xxx);
RESTORE_SUB
XSB_End_Instr()
XSB_Start_Instr(try,_try) /* PPA-L */
Def2ops
Op1(get_xxa);
op2 = (Cell)((Cell)lpcreg + sizeof(Cell)*2);
#if 0
{
Psc mypsc = *(CPtr)(cpreg-4);
if (mypsc)
if (get_type(mypsc) == T_PRED) {
fprintf(stddbg,"creating_cp(try(%s/%d), %p).\n",
get_name(mypsc), get_arity(mypsc), breg);
}
}
#endif
lpcreg = *(pb *)(lpcreg+sizeof(Cell)); /* = *(pointer to byte pointer) */
SUBTRYME
XSB_End_Instr()
XSB_Start_Instr(retry,_retry) /* PPA-L */
Def1op
Op1(get_xxa);
cp_pcreg(breg) = lpcreg+sizeof(Cell)*2;
lpcreg = *(pb *)(lpcreg+sizeof(Cell));
restore_type = 0;
RESTORE_SUB
XSB_End_Instr()
XSB_Start_Instr(trust,_trust) /* PPA-L */
Def1op
Op1(get_xxa);
lpcreg = *(pb *)(lpcreg+sizeof(Cell));
restore_type = 1;
RESTORE_SUB
XSB_End_Instr()
XSB_Start_Instr(getVn,_getVn) /* PPV */
Def1op
Op1(get_xxv);
ADVANCE_PC(size_xxx);
cell((CPtr)op1) = (Cell)tcp_subgoal_ptr(breg);
XSB_End_Instr()
XSB_Start_Instr(getpbreg,_getpbreg) /* PPV */
Def1op
Op1(get_xxv);
ADVANCE_PC(size_xxx);
bld_int((CPtr)op1, ((pb)tcpstack.high - (pb)breg));
XSB_End_Instr()
XSB_Start_Instr(gettbreg,_gettbreg) /* PPR */
Def1op
Op1(get_xxr);
ADVANCE_PC(size_xxx);
bld_int((CPtr)op1, ((pb)tcpstack.high - (pb)breg));
XSB_End_Instr()
XSB_Start_Instr(putpbreg,_putpbreg) /* PPV */
Def1op
Op1(Variable(get_xxv));
ADVANCE_PC(size_xxx);
cut_code(op1);
XSB_End_Instr()
XSB_Start_Instr(puttbreg,_puttbreg) /* PPR */
Def1op
Op1(Register(get_xxr));
ADVANCE_PC(size_xxx);
cut_code(op1);
XSB_End_Instr()
XSB_Start_Instr(jumptbreg,_jumptbreg) /* PPR-L */ /* ??? */
Def1op
Op1(get_xxr);
bld_int((CPtr)op1, ((pb)tcpstack.high - (pb)breg));
lpcreg = *(byte **)(lpcreg+sizeof(Cell));
XSB_End_Instr()
XSB_Start_Instr(test_heap,_test_heap) /* PPA-N */
Def2ops
Op1(get_xxa); /* op1 = the arity of the procedure */
Op2(get_xxxn);
ADVANCE_PC(size_xxxX);
#ifdef GC_TEST
if ((infcounter++ > GC_INFERENCES) || ((ereg - hreg) < (long)op2))
{
infcounter = 0;
fprintf(stddbg, ".");
#else
if ((ereg - hreg) < (long)op2)
{
#endif
if (gc_heap(op1)) { /* garbage collection potentially modifies hreg */
if ((ereg - hreg) < (long)op2) {
if (flags[STACK_REALLOC]) {
if (glstack_realloc(resize_stack(glstack.size,(op2*sizeof(Cell))),op1) != 0) {
xsb_basic_abort(local_global_exception);
}
} else {
xsb_warn("Reallocation is turned OFF !");
xsb_basic_abort(local_global_exception);
}
}
}
/* are there any localy cached quantities that must be reinstalled ? */
}
XSB_End_Instr()
XSB_Start_Instr(switchonterm,_switchonterm) /* PPR-L-L */
Def1op
Op1(Register(get_xxr));
XSB_Deref(op1);
switch (cell_tag(op1)) {
case XSB_INT:
case XSB_STRING:
case XSB_FLOAT:
lpcreg = *(pb *)(lpcreg+sizeof(Cell));
break;
case XSB_FREE:
case XSB_REF1:
case XSB_ATTV:
ADVANCE_PC(size_xxxXX);
break;
case XSB_STRUCT:
if (get_arity(get_str_psc(op1)) == 0) {
lpcreg = *(pb *)(lpcreg+sizeof(Cell));
break;
}
case XSB_LIST: /* include structure case here */
lpcreg = *(pb *)(lpcreg+sizeof(Cell)*2);
break;
}
XSB_End_Instr()
XSB_Start_Instr(switchonbound,_switchonbound) /* PPR-L-L */
Def3ops
/* op1 is register, op2 is hash table offset, op3 is modulus */
Op1(get_xxr);
XSB_Deref(op1);
switch (cell_tag(op1)) {
case XSB_STRUCT:
op1 = (Cell)get_str_psc(op1);
break;
case XSB_STRING: /* We should change the compiler to avoid this test */
op1 = (Cell)(isnil(op1) ? 0 : string_val(op1));
break;
case XSB_INT:
case XSB_FLOAT: /* Yes, use int_val to avoid conversion problem */
op1 = (Cell)int_val(op1);
break;
case XSB_LIST:
op1 = (Cell)(list_str);
break;
case XSB_FREE:
case XSB_REF1:
case XSB_ATTV:
lpcreg += 3 * sizeof(Cell);
XSB_Next_Instr();
}
op2 = (Cell)(*(byte **)(lpcreg+sizeof(Cell)));
op3 = *(CPtr *)(lpcreg+sizeof(Cell)*2);
/* doc tls -- op2 + (op1%size)*4 */
lpcreg =
*(byte **)((byte *)op2 + ihash((Cell)op1, (Cell)op3) * sizeof(Cell));
XSB_End_Instr()
XSB_Start_Instr(switchon3bound,_switchon3bound) /* RRR-L-L */
Def3ops
int i, j = 0;
int indexreg[3];
Cell opa[3];
/* op1 is register contents, op2 is hash table offset, op3 is modulus */
indexreg[0] = get_axx;
indexreg[1] = get_xax;
indexreg[2] = get_xxa;
if (*lpcreg == 0) { opa[0] = 0; }
else opa[0] = Register((rreg + (indexreg[0] & 0x7f)));
opa[1] = Register((rreg + (indexreg[1] & 0x7f)));
opa[2] = Register((rreg + (indexreg[2] & 0x7f)));
op2 = (Cell)(*(byte **)(lpcreg+sizeof(Cell)));
op3 = *(CPtr *)(lpcreg+sizeof(Cell)*2);
/* This is not a good way to do this, but until we put retract into C,
or add new builtins, it will have to do. */
for (i = 0; i <= 2; i++) {
if (opa[i] != 0) {
if (indexreg[i] > 0x80) {
int k, depth = 0;
Cell *stk[MAXTOINDEX];
int argsleft[MAXTOINDEX];
stk[0] = &opa[i];
argsleft[0] = 1;
for (k = MAXTOINDEX; k > 0; k--) {
if (depth < 0) break;
op1 = *stk[depth];
argsleft[depth]--;
if (argsleft[depth] <= 0) depth--;
else stk[depth]++;
XSB_Deref(op1);
switch (cell_tag(op1)) {
case XSB_FREE:
case XSB_REF1:
case XSB_ATTV:
ADVANCE_PC(size_xxxXX);
XSB_Next_Instr();
case XSB_INT:
case XSB_FLOAT: /* Yes, use int_val to avoid conversion problem */
op1 = (Cell)int_val(op1);
break;
case XSB_LIST:
depth++;
argsleft[depth] = 2;
stk[depth] = clref_val(op1);
op1 = (Cell)(list_str);
break;
case XSB_STRUCT:
depth++;
argsleft[depth] = get_arity(get_str_psc(op1));
stk[depth] = clref_val(op1)+1;
op1 = (Cell)get_str_psc(op1);
break;
case XSB_STRING:
op1 = (Cell)string_val(op1);
break;
}
j = (j<<1) + ihash((Cell)op1, (Cell)op3);
}
} else {
op1 = opa[i];
XSB_Deref(op1);
switch (cell_tag(op1)) {
case XSB_FREE:
case XSB_REF1:
case XSB_ATTV:
ADVANCE_PC(size_xxxXX);
XSB_Next_Instr();
case XSB_INT:
case XSB_FLOAT: /* Yes, use int_val to avoid conversion problem */
op1 = (Cell)int_val(op1);
break;
case XSB_LIST:
op1 = (Cell)(list_str);
break;
case XSB_STRUCT:
op1 = (Cell)get_str_psc(op1);
break;
case XSB_STRING:
op1 = (Cell)string_val(op1);
break;
default:
xsb_error("Illegal operand in switchon3bound");
break;
}
j = (j<<1) + ihash((Cell)op1, (Cell)op3);
}
}
}
lpcreg = *(byte **)((byte *)op2 + ((j % (Cell)op3) * sizeof(Cell)));
XSB_End_Instr()
XSB_Start_Instr(trymeorelse,_trymeorelse) /* PPA-L */
Def2ops
Op1(0);
Op2(get_xxxl);
#if 0
{
Psc mypsc = *(CPtr)(cpreg-4);
if (mypsc)
if (get_type(mypsc) == T_PRED) {
fprintf(stddbg,"creating_cp(trymeorelse(%s/%d), %p).\n",
get_name(mypsc), get_arity(mypsc), breg);
}
}
#endif
ADVANCE_PC(size_xxxX);
cpreg = lpcreg;
SUBTRYME
XSB_End_Instr()
XSB_Start_Instr(retrymeorelse,_retrymeorelse) /* PPA-L */
Def1op
Op1(0);
cp_pcreg(breg) = *(byte **)(lpcreg+sizeof(Cell));
ADVANCE_PC(size_xxxX);
cpreg = lpcreg;
restore_type = 0;
RESTORE_SUB
XSB_End_Instr()
XSB_Start_Instr(trustmeorelsefail,_trustmeorelsefail) /* PPA */
Def1op
Op1(0);
ADVANCE_PC(size_xxx);
cpreg = lpcreg+sizeof(Cell);
restore_type = 1;
RESTORE_SUB
XSB_End_Instr()
XSB_Start_Instr(dyntrustmeelsefail,_dyntrustmeelsefail) /* PPA-L, second word ignored */
Def1op
Op1(get_xxa);
ADVANCE_PC(size_xxxX);
restore_type = 1;
RESTORE_SUB
XSB_End_Instr()
/*----------------------------------------------------------------------*/
#include "slginsts_xsb_i.h"
#include "tc_insts_xsb_i.h"
/*----------------------------------------------------------------------*/
XSB_Start_Instr(term_comp,_term_comp) /* RRR */
Def3ops
Op1(get_rxx);
Op2(get_xrx);
Op3(get_xxr);
ADVANCE_PC(size_xxx);
bld_int(op3, compare((void *)op1, (void *)op2));
XSB_End_Instr()
XSB_Start_Instr(movreg,_movreg) /* PRR */
Def2ops
Op1(get_xrx);
Op2(get_xxr);
ADVANCE_PC(size_xxx);
bld_copy((CPtr) op2, *((CPtr)op1));
XSB_End_Instr()
#define ARITHPROC(OP, STROP) \
Op1(Register(get_xrx)); \
Op3(get_xxr); \
ADVANCE_PC(size_xxx); \
op2 = *(op3); \
XSB_Deref(op1); \
XSB_Deref(op2); \
if (isinteger(op1)) { \
if (isinteger(op2)) { \
Integer temp = int_val(op2) OP int_val(op1); \
bld_oint(op3, temp); } \
else if (isfloat(op2)) { \
Float temp = float_val(op2) OP (Float)int_val(op1); \
bld_float(op3, temp); } \
else if (isboxedinteger(op2)) { \
Integer temp = boxedint_val(op2) OP int_val(op1); \
bld_oint(op3, temp); } \
else { arithmetic_abort(op2, STROP, op1); } \
} else if (isfloat(op1)) { \
if (isfloat(op2)) { \
Float temp = float_val(op2) OP float_val(op1); \
bld_float(op3, temp); } \
else if (isinteger(op2)) { \
Float temp = (Float)int_val(op2) OP float_val(op1); \
bld_float(op3, temp); } \
else if (isboxedinteger(op2)) { \
Float temp = (Float)boxedint_val(op2) OP float_val(op1); \
bld_float(op3, temp); } \
else { arithmetic_abort(op2, STROP, op1); } \
} else if (isboxedinteger(op1)) { \
if (isinteger(op2)) { \
Integer temp = int_val(op2) OP boxedint_val(op1); \
bld_oint(op3, temp); } \
else if (isboxedinteger(op2)) { \
Integer temp = boxedint_val(op2) OP boxedint_val(op1); \
bld_oint(op3, temp); } \
else if (isfloat(op2)) { \
Float temp = float_val(op2) OP (Float)boxedint_val(op1); \
bld_float(op3, temp); } \
else { arithmetic_abort(op2, STROP, op1); } \
} else { arithmetic_abort(op2, STROP, op1); }
XSB_Start_Instr(addreg,_addreg) /* PRR */
Def3ops
ARITHPROC(+, "+");
XSB_End_Instr()
XSB_Start_Instr(subreg,_subreg) /* PRR */
Def3ops
ARITHPROC(-, "-");
/** Op1(Register(get_xrx));
Op3(get_xxr);
ADVANCE_PC(size_xxx);
op2 = *(op3);
XSB_Deref(op1);
XSB_Deref(op2);
if (isinteger(op1)) {
if (isinteger(op2)) {
Integer temp = int_val(op2) - int_val(op1);
bld_oint(op3, temp); }
else if (isfloat(op2)) {
Float temp = float_val(op2) - (Float)int_val(op1);
bld_float(op3, temp); }
else if (isboxedinteger(op2)) {
Integer temp = boxedint_val(op2) - int_val(op1);
bld_oint(op3, temp); }
else { arithmetic_abort(op2, "-", op1); }
} else if (isfloat(op1)) {
if (isfloat(op2)) {
Float temp = float_val(op2) - float_val(op1);
bld_float(op3, temp); }
else if (isinteger(op2)) {
Float temp = (Float)int_val(op2) - float_val(op1);
bld_float(op3, temp); }
else if (isboxedinteger(op2)) {
Float temp = (Float)boxedint_val(op2) - float_val(op1);
bld_float(op3, temp); }
else arithmetic_abort(op2, "-", op1);
} else if (isboxedinteger(op1)) {
if (isinteger(op2)) {
Integer temp = int_val(op2) - boxedint_val(op1);
bld_oint(op3, temp); }
else if (isboxedinteger(op2)) {
Integer temp = boxedint_val(op2) - boxedint_val(op1);
bld_oint(op3, temp); }
else if (isfloat(op2)) {
Float temp = float_val(op2) - (Float)boxedint_val(op1);
bld_float(op3, temp); }
else { arithmetic_abort(op2, "-", op1); }
} else arithmetic_abort(op2, "-", op1); ****/
XSB_End_Instr()
XSB_Start_Instr(mulreg,_mulreg) /* PRR */
Def3ops
ARITHPROC(*, "*");
XSB_End_Instr()
XSB_Start_Instr(divreg,_divreg) /* PRR */
Def3ops
Op1(Register(get_xrx));
Op3(get_xxr);
ADVANCE_PC(size_xxx);
op2 = *(op3);
XSB_Deref(op1);
XSB_Deref(op2);
if (isinteger(op1)) {
if (isinteger(op2)) {
Float temp = (Float)int_val(op2)/(Float)int_val(op1);
bld_float(op3, temp); }
else if (isfloat(op2)) {
Float temp = float_val(op2)/(Float)int_val(op1);
bld_float(op3, temp); }
else if (isboxedinteger(op2)) {
Float temp = (Float)boxedint_val(op2)/(Float)int_val(op1);
bld_float(op3, temp); }
else { arithmetic_abort(op2, "/", op1); }
} else if (isfloat(op1)) {
if (isfloat(op2)) {
Float temp = float_val(op2)/float_val(op1);
bld_float(op3, temp); }
else if (isinteger(op2)) {
Float temp = (Float)int_val(op2)/float_val(op1);
bld_float(op3, temp); }
else if (isboxedinteger(op2)) {
Float temp = (Float)boxedint_val(op2)/float_val(op1);
bld_float(op3, temp); }
else { arithmetic_abort(op2, "/", op1); }
} else if (isboxedinteger(op1)) {
if (isinteger(op2)) {
Float temp = (Float)int_val(op2) / (Float)boxedint_val(op1);
bld_float(op3, temp); }
else if (isboxedinteger(op2)) {
Integer temp = (Float)boxedint_val(op2) / (Float)boxedint_val(op1);
bld_float(op3, temp); }
else if (isfloat(op2)) {
Float temp = (Float)float_val(op2) / (Float)boxedint_val(op1);
bld_float(op3, temp); }
else { arithmetic_abort(op2, "/", op1); }
} else { arithmetic_abort(op2, "/", op1); }
XSB_End_Instr()
XSB_Start_Instr(idivreg,_idivreg) /* PRR */
Def3ops
Op1(Register(get_xrx));
Op3(get_xxr);
ADVANCE_PC(size_xxx);
op2 = *(op3);
XSB_Deref(op1);
XSB_Deref(op2);
if (isinteger(op1)) {
if (int_val(op1) != 0) {
if (isinteger(op2)) {
Integer temp = int_val(op2) / int_val(op1);
bld_oint(op3, temp);
} else if (isboxedinteger(op2)) {
Integer temp = boxedint_val(op2) / int_val(op1);
bld_oint(op3, temp);
} else { arithmetic_abort(op2, "//", op1); }
} else {
err_handle(ZERO_DIVIDE, 2,
"arithmetic expression involving is/2 or eval/2",
2, "non-zero number", op1);
lpcreg = pcreg;
}
} else if (isboxedinteger(op1)) {
if (isinteger(op2)) {
Integer temp = int_val(op2) / boxedint_val(op1);
bld_oint(op3, temp);
} else if (isboxedinteger(op2)) {
Integer temp = boxedint_val(op2) / boxedint_val(op1);
bld_oint(op3, temp);
}
}
else { arithmetic_abort(op2, "//", op1); }
XSB_End_Instr()
XSB_Start_Instr(int_test_z,_int_test_z) /* PPR-B-L */
Def3ops
Op1(Register(get_xxr));
Op2(get_xxxn);
Op3(get_xxxxl);
ADVANCE_PC(size_xxxXX);
XSB_Deref(op1);
if (isnumber(op1)) {
if (op1 == op2)
lpcreg = (byte *)op3;
}
else if (isboxedinteger(op1)) {
if (oint_val(op1) == oint_val(op2))
lpcreg = (byte *)op3;
}
else {
arithmetic_comp_abort(op1, "=\\=", op2);
}
XSB_End_Instr()
XSB_Start_Instr(int_test_nz,_int_test_nz) /* PPR-B-L */
Def3ops
Op1(Register(get_xxr));
Op2(get_xxxn);
Op3(get_xxxxl);
ADVANCE_PC(size_xxxXX);
XSB_Deref(op1);
if (isnumber(op1)) {
if (op1 != op2)
lpcreg = (byte *) op3;
}
else if (isboxedinteger(op1)) {
if (oint_val(op1) != oint_val(op2))
lpcreg = (byte *)op3;
}
else {
arithmetic_comp_abort(op1, "=:=", op2);
}
XSB_End_Instr()
XSB_Start_Instr(putdval,_putdval) /* PVR */
Def2ops
Op1(Variable(get_xvx));
Op2(get_xxr);
ADVANCE_PC(size_xxx);
XSB_Deref(op1);
bld_copy((CPtr)op2, op1);
XSB_End_Instr()
XSB_Start_Instr(putuval,_putuval) /* PVR */
Def2ops
Op1(Variable(get_xvx));
Op2(get_xxr);
ADVANCE_PC(size_xxx);
XSB_Deref(op1);
if (isnonvar(op1) || ((CPtr)(op1) < hreg) || ((CPtr)(op1) >= ereg)) {
bld_copy((CPtr)op2, op1);
} else {
bld_ref((CPtr)op2, hreg);
bind_ref((CPtr)(op1), hreg);
new_heap_free(hreg);
}
XSB_End_Instr()
/*
* Instruction `check_interrupt' is used before `new_answer_dealloc' to
* handle the pending attv interrupts. It is similar to `call' but the
* second argument (S) is not used currently.
*/
XSB_Start_Instr(check_interrupt,_check_interrupt) /* PPA-S */
Def1op
Op1(get_xxxs);
ADVANCE_PC(size_xxxX);
if (int_val(cell(interrupt_reg)) > 0) {
cpreg = lpcreg;
bld_cs(reg + 2, hreg); /* see subp.c: build_call() */
new_heap_functor(hreg, true_psc);
bld_copy(reg + 1, build_interrupt_chain());
lpcreg = get_ep((Psc) flags[MYSIG_ATTV + INT_HANDLERS_FLAGS_START]);
}
XSB_End_Instr()
XSB_Start_Instr(call,_call) /* PPA-S */
Def1op
Psc psc;
Op1(get_xxxs); /* the first arg is used later by alloc */
ADVANCE_PC(size_xxxX);
cpreg = lpcreg;
psc = (Psc)op1;
#ifdef CP_DEBUG
pscreg = psc;
#endif
call_sub(psc);
XSB_End_Instr()
XSB_Start_Instr(call_forn,_call_forn) /* PPP-L, maybe use userfun instr? */
Def1op
Op1(get_xxxl);
ADVANCE_PC(size_xxxX);
if (((PFI)op1)()) /* call foreign function */
lpcreg = cpreg;
else Fail1;
XSB_End_Instr()
XSB_Start_Instr(load_pred,_load_pred) /* PPP-S */
Def1op
Psc psc;
Op1(get_xxxs);
ADVANCE_PC(size_xxxX);
psc = (Psc)op1;
/* check env or type to give (better) error msgs? */
switch (get_type(psc)) {
case T_PRED:
case T_DYNA:
xsb_abort("[EMULOOP] Trying to load an already loaded pred");
default:
/* xsb_dbgmsg("loading module %s for %s/%d\n",
get_name(get_data(psc)),get_name(psc),get_arity(psc)); */
bld_cs(reg+1, build_call(psc)); /* put call-term in r1 */
/* get psc of undef handler */
psc = (Psc)flags[MYSIG_UNDEF+INT_HANDLERS_FLAGS_START];
bld_int(reg+2, MYSIG_UNDEF); /* undef-pred code */
lpcreg = get_ep(psc); /* ep of undef handler */
break;
}
XSB_End_Instr()
XSB_Start_Instr(allocate_gc,_allocate_gc) /* PAA */
Def3ops
Op2(get_xax);
Op3((CPtr) (int)get_xxa);
ADVANCE_PC(size_xxx);
if (efreg_on_top(ereg))
op1 = (Cell)(efreg-1);
else {
if (ereg_on_top(ereg)) op1 = (Cell)(ereg - *(cpreg-2*sizeof(Cell)+3));
else op1 = (Cell)(ebreg-1);
}
*(CPtr *)((CPtr) op1) = ereg;
*((byte **) (CPtr)op1-1) = cpreg;
ereg = (CPtr)op1;
{/* initialize all permanent variables not in the first chunk to unbound */
int i = ((Cell)op3) - op2;
CPtr p = ((CPtr)op1) - op2;
while (i--) {
bld_free(p);
p--;
}
}
XSB_End_Instr()
/* This is obsolete and is only kept for backwards compatibility for < 2.0 */
XSB_Start_Instr(allocate,_allocate) /* PPP */
Def1op
ADVANCE_PC(size_xxx);
if (efreg_on_top(ereg))
op1 = (Cell)(efreg-1);
else {
if (ereg_on_top(ereg)) op1 = (Cell)(ereg - *(cpreg-2*sizeof(Cell)+3));
else op1 = (Cell)(ebreg-1);
}
*(CPtr *)((CPtr) op1) = ereg;
*((byte **) (CPtr)op1-1) = cpreg;
ereg = (CPtr)op1;
{ /* for old object files initialize pessimisticly but safely */
int i = 256;
CPtr p = ((CPtr)op1)-2;
while (i--) {
bld_free(p);
p--;
}
}
XSB_End_Instr()
XSB_Start_Instr(deallocate,_deallocate) /* PPP */
ADVANCE_PC(size_xxx);
cpreg = *((byte **)ereg-1);
ereg = *(CPtr *)ereg;
XSB_End_Instr()
XSB_Start_Instr(proceed,_proceed) /* PPP */
lpcreg = cpreg;
XSB_End_Instr()
XSB_Start_Instr(execute,_execute) /* PPP-S */
Def1op
Psc psc;
Op1(get_xxxs);
ADVANCE_PC(size_xxxX);
psc = (Psc)op1;
#ifdef CP_DEBUG
pscreg = psc;
#endif
call_sub(psc);
XSB_End_Instr()
XSB_Start_Instr(jump,_jump) /* PPP-L */
lpcreg = (byte *)get_xxxl;
XSB_End_Instr()
XSB_Start_Instr(jumpz,_jumpz) /* PPR-L */
Def1op
Op1(Register(get_xxr));
if (int_val(op1) == 0)
lpcreg = (byte *)get_xxxl;
else
ADVANCE_PC(size_xxxX);
XSB_End_Instr()
XSB_Start_Instr(jumpnz,_jumpnz) /* PPR-L */
Def1op
Op1(Register(get_xxr));
if (oint_val(op1) != 0)
lpcreg = (byte *)get_xxxl;
else ADVANCE_PC(size_xxxX);;
XSB_End_Instr()
XSB_Start_Instr(jumplt,_jumplt) /* PPR-L */
Def1op
Op1(Register(get_xxr));
if (isinteger(op1)) {
if (int_val(op1) < 0) lpcreg = (byte *)get_xxxl;
else {ADVANCE_PC(size_xxxX);}
} else if (isfloat(op1)) {
if (float_val(op1) < 0.0) lpcreg = (byte *)get_xxxl;
else {ADVANCE_PC(size_xxxX);}
} else if (isboxedinteger(op1)) {
if (boxedint_val(op1) < 0) lpcreg = (byte *)get_xxxl;
else {ADVANCE_PC(size_xxxX);}
}
XSB_End_Instr()
XSB_Start_Instr(jumple,_jumple) /* PPR-L */
Def1op
Op1(Register(get_xxr));
if (isinteger(op1)) {
if (int_val(op1) <= 0) lpcreg = (byte *)get_xxxl;
else {ADVANCE_PC(size_xxxX);}
} else if (isfloat(op1)) {
if (float_val(op1) <= 0.0) lpcreg = (byte *)get_xxxl;
else {ADVANCE_PC(size_xxxX);}
} else if (isboxedinteger(op1)) {
if (boxedint_val(op1) <= 0) lpcreg = (byte *)get_xxxl;
else {ADVANCE_PC(size_xxxX);}
}
XSB_End_Instr()
XSB_Start_Instr(jumpgt,_jumpgt) /* PPR-L */
Def1op
Op1(Register(get_xxr));
if (isinteger(op1)) {
if (int_val(op1) > 0) lpcreg = (byte *)get_xxxl;
else {ADVANCE_PC(size_xxxX);}
} else if (isfloat(op1)) {
if (float_val(op1) > 0.0) lpcreg = (byte *)get_xxxl;
else {ADVANCE_PC(size_xxxX);}
} else if (isboxedinteger(op1)) {
if (boxedint_val(op1) > 0) lpcreg = (byte *)get_xxxl;
else {ADVANCE_PC(size_xxxX);}
}
XSB_End_Instr()
XSB_Start_Instr(jumpge,_jumpge) /* PPR-L */
Def1op
Op1(Register(get_xxr));
if (isinteger(op1)) {
if (int_val(op1) >= 0) lpcreg = (byte *)get_xxxl;
else {ADVANCE_PC(size_xxxX);}
} else if (isfloat(op1)) {
if (float_val(op1) >= 0.0) lpcreg = (byte *)get_xxxl;
else {ADVANCE_PC(size_xxxX);}
} else if (isboxedinteger(op1)) {
if (boxedint_val(op1) >= 0) lpcreg = (byte *)get_xxxl;
else {ADVANCE_PC(size_xxxX);}
}
XSB_End_Instr()
XSB_Start_Instr(fail,_fail) /* PPP */
Fail1;
XSB_End_Instr()
XSB_Start_Instr(noop,_noop) /* PPA */
Def1op
Op1(get_xxa);
ADVANCE_PC(size_xxx);
lpcreg += (int)op1;
lpcreg += (int)op1;
XSB_End_Instr()
XSB_Start_Instr(halt,_halt) /* PPP */
ADVANCE_PC(size_xxx);
pcreg = lpcreg;
inst_begin = lpcreg; /* hack for the moment to make this a ``creturn'' */
return(0); /* not "goto contcase"! */
XSB_End_Instr()
XSB_Start_Instr(builtin,_builtin)
Def1op
Op1(get_xxa);
ADVANCE_PC(size_xxx);
pcreg=lpcreg;
if (builtin_call((byte)(op1))) {lpcreg=pcreg;}
else Fail1;
XSB_End_Instr()
XSB_Start_Instr(unifunc,_unifunc) /* PAR */
Def2ops
Op1(get_xax);
Op2(get_xxr);
ADVANCE_PC(size_xxx);
if (unifunc_call((int)(op1), (CPtr)op2) == 0) {
xsb_error("Error in unary function call");
Fail1;
}
XSB_End_Instr()
XSB_Start_Instr(calld,_calld) /* PPA-L */
ADVANCE_PC(size_xxx); /* this is ok */
cpreg = lpcreg+sizeof(Cell);
check_glstack_overflow(MAX_ARITY, lpcreg,OVERFLOW_MARGIN);
lpcreg = *(pb *)lpcreg;
XSB_End_Instr()
XSB_Start_Instr(logshiftr,_logshiftr) /* PRR */
Def3ops
Op1(Register(get_xrx));
Op3(get_xxr);
ADVANCE_PC(size_xxx);
op2 = *(op3);
XSB_Deref(op1);
XSB_Deref(op2);
if (isinteger(op1)) {
if (isinteger(op2)) {
Integer temp = int_val(op2) >> int_val(op1);
bld_oint(op3, temp);
}
else if (isboxedinteger(op2)) {
Integer temp = boxedint_val(op2) >> int_val(op1);
bld_oint(op3, temp);
}
else {arithmetic_abort(op2, "'>>'", op1);}
}
else if (isboxedinteger(op1)) {
if (isinteger(op2)) {
Integer temp = int_val(op2) >> boxedint_val(op1);
bld_oint(op3, temp);
}
else if (isboxedinteger(op2)) {
Integer temp = boxedint_val(op2) >> boxedint_val(op1);
bld_oint(op3, temp);
}
else {arithmetic_abort(op2, "'>>'", op1);}
}
else {arithmetic_abort(op2, "'>>'", op1);}
XSB_End_Instr()
XSB_Start_Instr(logshiftl,_logshiftl) /* PRR */
Def3ops
Op1(Register(get_xrx));
Op3(get_xxr);
ADVANCE_PC(size_xxx);
op2 = *(op3);
XSB_Deref(op1);
XSB_Deref(op2);
if (isinteger(op1)) {
if (isinteger(op2)) {
Integer temp = int_val(op2) << int_val(op1);
bld_oint(op3, temp);
}
else if (isboxedinteger(op2)) {
Integer temp = boxedint_val(op2) << int_val(op1);
bld_oint(op3, temp);
}
else {arithmetic_abort(op2, "'<<'", op1);}
}
else if (isboxedinteger(op1)) {
if (isinteger(op2)) {
Integer temp = int_val(op2) << boxedint_val(op1);
bld_oint(op3, temp);
}
else if (isboxedinteger(op2)) {
Integer temp = boxedint_val(op2) << boxedint_val(op1);
bld_oint(op3, temp);
}
else {arithmetic_abort(op2, "'<<'", op1);}
}
else {arithmetic_abort(op2, "'<<'", op1);}
XSB_End_Instr()
XSB_Start_Instr(or,_or) /* PRR */
Def3ops
Op1(Register(get_xrx));
Op3(get_xxr);
ADVANCE_PC(size_xxx);
op2 = *(op3);
XSB_Deref(op1);
XSB_Deref(op2);
if (isinteger(op1)) {
if (isinteger(op2)) {
Integer temp = (int_val(op2)) | (int_val(op1));
bld_oint(op3, temp);
}
else if (isboxedinteger(op2)) {
Integer temp = (boxedint_val(op2)) | (int_val(op1));
bld_oint(op3, temp);
}
else {arithmetic_abort(op2, "'\\/'", op1);}
}
else if (isboxedinteger(op1)) {
if (isinteger(op2)) {
Integer temp = (int_val(op2)) | (boxedint_val(op1));
bld_oint(op3, temp);
}
else if (isboxedinteger(op2)) {
Integer temp = (boxedint_val(op2)) | (boxedint_val(op1));
bld_oint(op3, temp);
}
else {arithmetic_abort(op2, "'\\/'", op1);}
}
else {arithmetic_abort(op2, "'\\/'", op1);}
/** if (!isinteger(op1) || !isinteger(op2)) {
arithmetic_abort(op2, "'\\/'", op1);
}
else { bld_oint(op3, int_val(op2) | int_val(op1)); } ***/
XSB_End_Instr()
XSB_Start_Instr(and,_and) /* PRR */
Def3ops
Op1(Register(get_xrx));
Op3(get_xxr);
ADVANCE_PC(size_xxx);
op2 = *(op3);
XSB_Deref(op1);
XSB_Deref(op2);
if (isinteger(op1)) {
if (isinteger(op2)) {
Integer temp = (int_val(op2)) & (int_val(op1));
bld_oint(op3, temp);
}
else if (isboxedinteger(op2)) {
Integer temp = (boxedint_val(op2)) & (int_val(op1));
bld_oint(op3, temp);
}
else {arithmetic_abort(op2, "'/\\'", op1);}
}
else if (isboxedinteger(op1)) {
if (isinteger(op2)) {
Integer temp = (int_val(op2)) & (boxedint_val(op1));
bld_oint(op3, temp);
}
else if (isboxedinteger(op2)) {
Integer temp = (boxedint_val(op2)) & (boxedint_val(op1));
bld_oint(op3, temp);
}
else {arithmetic_abort(op2, "'/\\'", op1);}
}
else {arithmetic_abort(op2, "'/\\'", op1);}
/** if (!isinteger(op1) || !isinteger(op2)) {
arithmetic_abort(op2, "'/\\'", op1);
}
else { bld_oint(op3, int_val(op2) & int_val(op1)); } **/
XSB_End_Instr()
XSB_Start_Instr(negate,_negate) /* PPR */
DefOps13
Op3(get_xxr);
ADVANCE_PC(size_xxx);
op1 = *(op3);
XSB_Deref(op1);
if (isinteger(op1)) { bld_int(op3, ~(int_val(op1))); }
else if (isboxedinteger(op1)) {
Integer temp = ~(boxedint_val(op1));
bld_oint(op3, temp);
}
else { arithmetic_abort1("'\\'", op1); }
XSB_End_Instr()
#ifndef JUMPTABLE_EMULOOP
default: {
char message[80];
sprintf(message, "Illegal opcode hex %x", *lpcreg);
xsb_exit(message);
}
} /* end of switch */
#else
_no_inst:
{
char message[80];
sprintf(message, "Illegal opcode hex %x", *lpcreg);
xsb_exit(message);
}
#endif
return 0;
} /* end of emuloop() */
/*======================================================================*/
/*======================================================================*/
DllExport int call_conv xsb(int flag, int argc, char *argv[])
{
char *startup_file;
FILE *fd;
unsigned int magic_num;
static double realtime; /* To retain its value across invocations */
extern void dis(xsbBool);
extern char *init_para(int, char **);
extern void init_machine(void), init_symbols(void);
#ifdef FOREIGN
#ifndef FOREIGN_ELF
#ifndef FOREIGN_WIN32
extern char tfile[];
#endif
#endif
#endif
if (flag == 0) { /* initialize xsb */
/* Set the name of the executable to the real name.
The name of the executable could have been set in cinterf.c:xsb_init
if XSB is called from C. In this case, we don't want `executable'
to be overwritten, so we check if it is initialized. */
#ifdef SIMPLESCALAR
strcpy(executable,argv[0]);
#else
if (executable[0] == '\0')
xsb_executable_full_path(argv[0]);
#endif
/* set install_dir, xsb_config_file and user_home */
set_install_dir();
set_config_file();
set_user_home();
realtime = real_time();
setbuf(stdout, NULL);
startup_file = init_para(argc, argv); /* init parameters */
init_machine(); /* init space, regs, stacks */
init_inst_table(); /* init table of instruction types */
init_symbols(); /* preset a few symbols in PSC table */
init_interrupt(); /* catch ^C interrupt signal */
/* "b" does nothing, but POSIX allows it */
fd = fopen(startup_file, "rb");
if (!fd) {
char message[256];
sprintf(message, "The startup file, %s, could not be found!",
startup_file);
xsb_exit(message);
}
magic_num = read_magic(fd);
fclose(fd);
if (magic_num == 0x11121307 || magic_num == 0x11121305)
inst_begin = loader(startup_file,0);
else
xsb_exit("Incorrect startup file format");
if (!inst_begin)
xsb_exit("Error in loading startup file");
if (xsb_mode == DISASSEMBLE) {
dis(1);
exit(0);
}
/* do it after initialization, so that typing
xsb -v or xsb -h won't create .xsb directory */
set_xsbinfo_dir();
return(0);
} else if (flag == 1) { /* continue execution */
return(emuloop(inst_begin));
} else if (flag == 2) { /* shutdown xsb */
#ifdef FOREIGN
#ifndef FOREIGN_ELF
#ifndef FOREIGN_WIN32
if (fopen(tfile, "r")) unlink(tfile);
#endif
#endif
#endif
if (xsb_mode != C_CALLING_XSB) {
realtime = real_time() - realtime;
fprintf(stdmsg, "\nEnd XSB (cputime %.2f secs, elapsetime ",
cpu_time());
if (realtime < 600.0)
fprintf(stdmsg, "%.2f secs)\n", realtime);
else
fprintf(stdmsg, "%.2f mins)\n", realtime/60.0);
}
return(0);
}
return(1);
} /* end of xsb() */
/*======================================================================*/
syntax highlighted by Code2HTML, v. 0.9.1