#include <stddef.h>
#include <stdlib.h>
#include <stdio.h>
#include <string.h>
#include <math.h>
#include <setjmp.h>
#include "cinterface.h"
/* #include "node.h" -- already included in cinterface.h */
/* #include "runtime.h" -- already included in node.h */
/* #include "bytecode.h" -- already included in node.h via newmacros.h */
#include "mutlib.h"
#include "mark.h"
#include "initend.h"
#if defined(__GNUC__) && !defined(DEBUG)
# define USE_GCC_LABELS 1
#else
# define USE_GCC_LABELS 0
#endif
#ifdef BYTECODE_PROF
/* for profiling bytecode instruction pairs/triples */
#define PAIR 0 /* for pairs, PAIR=1, for triples, PAIR=0 */
#if PAIR
static int total_instr_count=0;
static int instr_pair[ENDCODE+1][ENDCODE+1];
static unsigned char last_instr=EVAL;
#define register_instr(x) instr_pair[last_instr][x]++; last_instr=x; \
total_instr_count++
#else
static int total_instr_count=0;
static int instr_triple[ENDCODE+1][ENDCODE+1][ENDCODE+1];
static unsigned char last_instr=EVAL;
static unsigned char penu_instr=EVAL;
#define register_instr(x) instr_triple[penu_instr][last_instr][x]++; \
penu_instr=last_instr; \
last_instr=x; \
total_instr_count++
#endif
#else
#define register_instr(x)
#endif
#if defined(__CYGWIN32__) || defined(__MINGW32__)
extern jmp_buf exit_mutator;
#else
extern sigjmp_buf exit_mutator;
#endif
NodePtr Hp;
NodePtr *Sp;
NodePtr *Fp;
CodePtr Ip;
#if 0
#define INSTR(x) fprintf(stderr,"eval: %s\n",x)
#else
#define INSTR(x)
#endif
#if TRACE
NodePtr stopHP;
CodePtr stopIP;
int inscount;
int stopInscount;
#endif
#ifdef PROFILE
static SInfo apply1ProfInfo = { "Runtime","<APPLY>","<APPLY.VAP>"};
static SInfo apply2ProfInfo = { "Runtime","<APPLY>","<APPLY.$>"};
static SInfo apply3ProfInfo = { "Runtime","<APPLY>","<APPLY.CAP>"};
/* static SInfo evalProfInfo = { "Runtime","<EVAL>","<EVAL.BlackHole>"}; */
static SInfo int1ProfInfo = { "Runtime","<unary_int_op>","Prelude.Int"};
static SInfo int2ProfInfo = { "Runtime","<binary_int_op>","Prelude.Int"};
static SInfo float1ProfInfo = { "Runtime","<unary_float_op>","Prelude.Float"};
static SInfo float2ProfInfo = { "Runtime","<binary_float_op>","Prelude.Float"};
static SInfo double1ProfInfo = { "Runtime","<unary_double_op>","Prelude.Double"};
static SInfo double2ProfInfo = { "Runtime","<binary_double_op>","Prelude.Double"};
static SInfo fromEnumProfInfo = { "Runtime","<fromEnum>","Prelude.Int"};
static SInfo toEnumProfInfo = { "Runtime","<toEnum>","<Enum>"};
static SInfo string1ProfInfo = { "Runtime","<STRING>","Prelude.Int"};
static SInfo string2ProfInfo = { "Runtime","<STRING>","<String_VAP>"};
static SInfo string3ProfInfo = { "Runtime","<STRING>","Prelude.:"};
static SInfo inpStringProfInfo = { "Runtime","<STRING>","<hGetContents_VAP>"};
/* static SInfo handleProfInfo = { "Runtime","<Handle>","IO.Handle"}; */
#endif
#define DUMP_NODE(n) fprintf(stderr," %08lx at %p\n",n[0],n);
#if PARANOID
#define ASSERT_W(i,n) \
if(CONSTR_INT != *(n)) { \
fprintf(stderr,"Ip = %08x: Expected Int but got ",i); \
DUMP_NODE(n); \
}
#define ASSERT_F(i,n) \
if(CONSTR_FLOAT != *(n)) { \
fprintf(stderr,"Ip = %08x: Expected Float but got ",i); \
DUMP_NODE(n); \
}
#define ASSERT_D(i,n) \
if(CONSTR_DOUBLE != *(n)) { \
fprintf(stderr,"Ip = %08x: Expected Double but got ",i); \
DUMP_NODE(n); \
}
#else
#define ASSERT_W(i,n)
#define ASSERT_F(i,n)
#define ASSERT_D(i,n)
#endif
#if defined(DEBUG)
#define SHOW(x) x
#if USE_GCC_LABELS
static char *instr_names[];
#endif
#else
#define SHOW(x)
#endif
void run(NodePtr toplevel)
{
NodePtr *sp, *fp, hp; /* -- shadow globals for efficiency */
CodePtr ip; /* -- shadow globals for efficiency */
NodePtr vapptr;
NodePtr nodeptr;
NodePtr *constptr = NULL;
TPROF_SETUP
#if USE_GCC_LABELS
# define ins(x) &&l##x
static void *labs[] = { INSTRUCTION_LIST };
# undef ins
# define Dispatch Break;
# define Case(x) l##x
# define Break SHOW(fprintf(stderr,"%s\t\t",instr_names[*ip]);) \
SHOW(fprintf(stderr,"hp=0x%x sp=0x%x fp=0x%x ip=0x%x\n",hp,sp,fp,ip);) \
register_instr(*ip); ip++; goto *labs[*(ip-1)]
# define EndDispatch
#else
# define Dispatch switch (*ip++) {
# define Case(x) case x
# define Break break
# define EndDispatch }
#endif
sp = Sp;
fp = Fp;
hp = Hp;
#ifdef TPROF
ip = (CodePtr)(LEAVE+NS); /* +NS (DAVID) */
TPROF_RUN;
#else
ip = (CodePtr)(LEAVE);
#endif
vapptr = toplevel;
goto EvalTOS;
for(;;) {
NextInst:
#if INSCOUNT
if(insCount)
countIns(ip);
#endif
Dispatch
Case(NEEDHEAP_I32): { printf("DEBUG: NEEDHEAP_I32\n"); HEAP_CHECK_VAP(32); } Break;
Case(NEEDHEAP_P1): { Int i = *ip++; HEAP_CHECK_VAP(i); } Break;
Case(NEEDHEAP_P2): { Int i = HEAPOFFSET(ip[0]) + (HEAPOFFSET(ip[1])<<8); ip+=2; HEAP_CHECK_VAP(i);} Break;
/* !!! Need stack !!! */
Case(NEEDSTACK_I16): { HEAP_CHECK_VAP(16); TPROF_NEEDSTACK_I16; } Break;
Case(NEEDSTACK_P1): { Int i = *ip++; HEAP_CHECK_VAP(i); } Break;
Case(NEEDSTACK_P2): { Int i = HEAPOFFSET(ip[0]) + (HEAPOFFSET(ip[1])<<8); ip+=2; HEAP_CHECK_VAP(i); } Break;
Case(JUMP): ip += HEAPOFFSET(ip[0]) + (HEAPOFFSET(ip[1])<<8); Break;
Case(JUMPFALSE): /* DAVID */
{ nodeptr = *sp++; IND_REMOVE(nodeptr);
UPDATE_PROFINFO(nodeptr)
if (GET_BOOL_VALUE(nodeptr) )
ip += 2;
else
ip += HEAPOFFSET(ip[0]) + (HEAPOFFSET(ip[1])<<8);
} Break;
Case(NOP):
fprintf(stderr,"Executed NOP at %p\n",ip);
Break;
Case(PRIMITIVE):
{ Primitive fun;
ip = (CodePtr) ALIGNPTR(ip);
fun = *(Primitive*)ip;
SHOW(fprintf(stderr,"\tPRIMITIVE %p\n",fun);)
fflush(stderr);
ip += sizeof(Primitive);
TPROF_GREENCARD_ENTER;
CALL_C(fun);
TPROF_GREENCARD_EXIT;
}
/* PRIMITIVE is always followed by RETURN_EVAL, so we elide the */
/* bytecode and jump direct. (Later, let's not generate the */
/* bytecode either.) */
/* ip++; */
/* goto return_eval; */
/* Ahem. It turns out in the new FFI that IO primitives are *not* */
/* always followed by RETURN_EVAL. */
Break;
Case(ZAP_ARG_I1): vapptr[EXTRA +1 ] = (Node)ZAP_ARG_NODE; printf("DEBUG: ZAP_ARG_I1\n"); Break;
Case(ZAP_ARG_I2): vapptr[EXTRA +2 ] = (Node)ZAP_ARG_NODE; Break;
Case(ZAP_ARG_I3): vapptr[EXTRA +3 ] = (Node)ZAP_ARG_NODE; Break;
Case(ZAP_ARG): vapptr[EXTRA +HEAPOFFSET(ip[0])] = (Node)ZAP_ARG_NODE; ip+=1; Break;
Case(ZAP_STACK_P1): sp[HEAPOFFSET(ip[0]) ] = ZAP_STACK_NODE; ip+=1; Break;
Case(ZAP_STACK_P2): sp[HEAPOFFSET(ip[0])+(HEAPOFFSET(ip[1])<<8)] = ZAP_STACK_NODE; ip+=2; Break;
Case(PUSH_CADR_N2): *--sp = (NodePtr)&constptr[-HEAPOFFSET(ip[0])-(HEAPOFFSET(ip[1])<<8)]; ip+=2; Break;
Case(PUSH_CADR_N1): *--sp = (NodePtr)&constptr[-HEAPOFFSET(ip[0])]; ip+=1; Break;
Case(PUSH_CADR_P1): *--sp = (NodePtr)&constptr[ HEAPOFFSET(ip[0])]; ip+=1; Break;
Case(PUSH_CADR_P2): *--sp = (NodePtr)&constptr[ HEAPOFFSET(ip[0])+(HEAPOFFSET(ip[1])<<8)]; ip+=2; Break;
Case(PUSH_CVAL_N2): *--sp = (NodePtr) constptr[-HEAPOFFSET(ip[0])-(HEAPOFFSET(ip[1])<<8)]; ip+=2; Break;
Case(PUSH_CVAL_N1): *--sp = (NodePtr) constptr[-HEAPOFFSET(ip[0])]; ip+=1; printf("DEBUG: PUSH_CVAL_N1\n"); Break;
Case(PUSH_CVAL_P1): *--sp = (NodePtr) constptr[ HEAPOFFSET(ip[0])]; ip+=1; Break;
Case(PUSH_CVAL_P2): *--sp = (NodePtr) constptr[ HEAPOFFSET(ip[0])+(HEAPOFFSET(ip[1])<<8)]; ip+=2; Break;
Case(PUSH_INT_N1): *--sp = GET_INT(-HEAPOFFSET(ip[0])); ip+=1; Break;
Case(PUSH_INT_P1): *--sp = GET_INT( HEAPOFFSET(ip[0])); ip+=1; Break;
Case(PUSH_CHAR_N1): *--sp = GET_CHAR(-HEAPOFFSET(ip[0])); ip+=1; Break;
Case(PUSH_CHAR_P1): *--sp = GET_CHAR( HEAPOFFSET(ip[0])); ip+=1; Break;
Case(PUSH_ARG_I1): UPDATE_PROFINFO(vapptr);
nodeptr =GET_POINTER_ARG1(vapptr,1);
IND_REMOVE(nodeptr);
*--sp = nodeptr; Break;
Case(PUSH_ARG_I2): UPDATE_PROFINFO(vapptr);
nodeptr =GET_POINTER_ARG1(vapptr,2);
IND_REMOVE(nodeptr);
*--sp = nodeptr; Break;
Case(PUSH_ARG_I3): UPDATE_PROFINFO(vapptr);
nodeptr =GET_POINTER_ARG1(vapptr,3);
IND_REMOVE(nodeptr);
*--sp = nodeptr; Break;
Case(PUSH_ARG): UPDATE_PROFINFO(vapptr);
nodeptr =GET_POINTER_ARG1(vapptr,ip[0]); ip+=1;
IND_REMOVE(nodeptr);
*--sp = nodeptr; Break;
Case(PUSH_ZAP_ARG_I1): UPDATE_PROFINFO(vapptr);
nodeptr =GET_POINTER_ARG1(vapptr,1);
IND_REMOVE(nodeptr);
*--sp = nodeptr;
vapptr[EXTRA +1] = (Node)ZAP_ARG_NODE; Break;
Case(PUSH_ZAP_ARG_I2): UPDATE_PROFINFO(vapptr);
nodeptr =GET_POINTER_ARG1(vapptr,2);
IND_REMOVE(nodeptr);
*--sp = nodeptr;
vapptr[EXTRA +2] = (Node)ZAP_ARG_NODE; Break;
Case(PUSH_ZAP_ARG_I3): UPDATE_PROFINFO(vapptr);
nodeptr =GET_POINTER_ARG1(vapptr,3);
IND_REMOVE(nodeptr);
*--sp = nodeptr;
vapptr[EXTRA +3] = (Node)ZAP_ARG_NODE; Break;
Case(PUSH_ZAP_ARG): UPDATE_PROFINFO(vapptr);
nodeptr =GET_POINTER_ARG1(vapptr,ip[0]);
IND_REMOVE(nodeptr);
*--sp = nodeptr;
vapptr[EXTRA +HEAPOFFSET(ip[0])] = (Node)ZAP_ARG_NODE;
ip+=1; Break;
Case(PUSH_HEAP): *--sp = hp; printf("DEBUG: PUSH_HEAP\n"); Break;
Case(PUSH_I1): nodeptr = sp[1]; *--sp = nodeptr; Break;
Case(PUSH_P1): nodeptr = sp[HEAPOFFSET(ip[0])]; *--sp = nodeptr; ip+=1; Break;
Case(PUSH_P2): nodeptr = sp[HEAPOFFSET(ip[0])+(HEAPOFFSET(ip[1])<<8)]; *--sp = nodeptr; ip+=2; Break;
Case(POP_I1): sp += 1; Break;
Case(POP_P1): sp += HEAPOFFSET(ip[0]); ip+=1; Break;
Case(POP_P2): sp += HEAPOFFSET(ip[0])+(HEAPOFFSET(ip[1])<<8) ; ip+=2; Break;
Case(SLIDE_P1): nodeptr = sp[0]; sp += HEAPOFFSET(ip[0]); sp[0] = nodeptr; ip+=1; Break;
Case(SLIDE_P2): nodeptr = sp[0]; sp += HEAPOFFSET(ip[0])+(HEAPOFFSET(ip[1])<<8) ; sp[0] = nodeptr; ip+=2; Break;
Case(SELECT):
{ Int index = *ip++;
nodeptr = *sp;
IND_REMOVE(nodeptr);
UPDATE_PROFINFO(nodeptr)
*sp = (NodePtr) GET_POINTER_ARG1(nodeptr,index);
TPROF_SELECT;
} goto return_eval;
Case(UNPACK):
#if PARANOID
{ int i;
nodeptr = sp[0];
IND_REMOVE(nodeptr);
switch(GET_LARGETAG(nodeptr)) {
case CON_DATA | CON_TAG:
case CON_CDATA | CON_TAG:
i = CONINFO_SIZE(GET_CONINFO(nodeptr));
break;
case CON_PTRS | CON_TAG:
case CON_WORDS | CON_TAG:
i = CONINFO_LARGESIZES(GET_CONINFO(nodeptr));
break;
default:
fprintf(stderr,"Trying to get tag from unevaluated node in UNPACK at %08x!\n",ip-1);
fprintf(stderr,"Node is:\n");
fprintf(stderr," %08x at %08x\n",nodeptr[0],nodeptr);
exit(-1);
Break;
}
if(i!=ip[0]) {
fprintf(stderr,"Trying to do UNPACK %d on a node with %d arguments at %08x!\n",ip[0],i,ip-1);
fprintf(stderr,"Node is:\n");
fprintf(stderr," %08x at %08x\n",nodeptr[0],nodeptr);
exit(-1);
}
}
#endif
{ Int arity = *ip++;
nodeptr = *sp++;
IND_REMOVE(nodeptr);
UPDATE_PROFINFO(nodeptr)
while (arity) {
*--sp = (NodePtr) GET_POINTER_ARG1(nodeptr,arity--);
}
} Break;
Case(APPLY):
INSTR("apply");
{ int need,size,args = *ip++;
Cinfo cinfo;
NodePtr vap;
nodeptr = *sp++;
IND_REMOVE(nodeptr);
UPDATE_PROFINFO(nodeptr)
cinfo = GET_CINFO(nodeptr);
#if PARANOID
{
int c = (GET_LARGETAG(nodeptr));
switch(c) {
case CON_DATA | CON_TAG:
case CON_CDATA | CON_TAG:
fprintf(stderr, "Strange: con in apply:\n");
fprintf(stderr, "\n");
/*startDbg(GET_POINTER_ARG1(nodeptr, 2));*/
exit(-1);
}
}
#endif /*0*/
#if 1
if(GET_TAG(nodeptr)&VAP_TAG && !CINFO_NEED(cinfo)) { /* Probably not needed */
/* Actually, this sometimes happens due to MKIORETURN. */
/*fprintf(stderr,"VAP in Apply?\n");*/
vap = nodeptr;
goto build_apply;
}
#endif
need = CINFO_NEED(cinfo);
size = CINFO_SIZE(cinfo);
nodeptr = nodeptr+1+EXTRA; /* Skip tag (and optional profile info) */
if(need <= args) {
INIT_PROFINFO(hp,&apply1ProfInfo)
vap = hp;
*hp++ = (Node)((UInt)2*need+(UInt)cinfo)+(UInt)VAP_TAG;
hp += EXTRA;
while(size-->0)
*hp++ = *nodeptr++;
args -= need;
while(need--)
*hp++ = (Node)*sp++;
build_apply:
while(args--) {
INIT_PROFINFO(hp,&apply2ProfInfo)
*hp++ = (Node)(C_VAPTAG(PRIM_APPLY));
hp += EXTRA;
*hp ++ = (Node) vap;
vap = &hp[-2-EXTRA];
*hp++ = (Node)*sp++;
}
} else { /* need > args */
INIT_PROFINFO(hp,&apply3ProfInfo)
vap = hp;
*hp++ = (Node)(2*(UInt)args+(UInt)VAP_TAG+(UInt)cinfo);
hp +=EXTRA;
while(size-->0)
*hp++ = *nodeptr++;
while(args-->0)
*hp++ = (Node)*sp++;
}
*--sp = vap;
} Break;
/* DON'T Fall trough to evaluate TOS. We might wan't to do RETURN_EVAL !!! */
Case(SELECTOR_EVAL): /* == PUSH_ARG 1, EVAL has it's own opcode to signal that this is a selector function (gc need to know) */
UPDATE_PROFINFO(vapptr);
nodeptr =GET_POINTER_ARG1(vapptr,1);
IND_REMOVE(nodeptr);
*--sp = nodeptr;
TPROF_SELECTOR_EVAL;
/* Fall through to EVAL */
Case(EVAL):
INSTR("evalToS");
EvalTOS:
{
printf("DEBUG: 1 vappptr = %x constptr = %x nodeptr = %x\n", vapptr, constptr, nodeptr);
nodeptr = sp[0];
printf("DEBUG: 2 vappptr = %x constptr = %x nodeptr = %x\n", vapptr, constptr, nodeptr);
IND_REMOVE(nodeptr);
UPDATE_PROFINFO(nodeptr)
sp[0] = nodeptr;
if(GET_TAG(nodeptr) & VAP_TAG && !CINFO_NEED(GET_CINFO(nodeptr))) {
if (ZAPPED(nodeptr)) {
nhc_abort("Black hole detected.");
/* The following out-commented commands basically just build
* a call to `error "Black hole detected."' in Haskell memory
* an call it; so the result is the same.
*/
#if 0
extern Node CF_DbgIface_46blackhole[];
extern Node FN_DbgIface_46fatal[];
fp = sp = spStart; /* Clear the stack */
/* There better be space left now. */
MK_VAP2(hp,C_VAPTAG(FN_DbgIface_46fatal),CON_NIL,(Node)CF_DbgIface_46blackhole);
/* Build a call to blackhole, in the future use function name */
INIT_PROFINFO(hp,&evalProfInfo)
*--sp = hp;
hp += SIZE_VAP2;
#if 0
MK_VAP1(hp,C_VAPTAG(BLACKHOLE),CON_NIL); /* Build a call to blackhole, in the future use function name */
INIT_PROFINFO(hp,&evalProfInfo)
*--sp = hp;
hp += SIZE_VAP1;
#endif
if (hp >= (NodePtr)sp) {
fprintf(stderr, "Black hole detected and no heap space available.\n");
exit(-1);
}
nodeptr = sp[0];
#endif
}
printf("DEBUG: ----------------------------------------------------------\n");
printf("DEBUG: EXT_HADDRESS = %x\n", EXT_HADDRESS(EXT_FINFO(GET_FINFO(vapptr))));
printf("DEBUG: EXT_FINFO = %x\n", EXT_FINFO(GET_FINFO(vapptr)));
printf("DEBUG: GET_FINFO = %x\n", GET_FINFO(vapptr));
printf("DEBUG: FINFO_CONST = %x\n", FINFO_CONST(GET_FINFO(vapptr)));
printf("DEBUG: VAPTAG = %x : %d\n", VAPTAG(1),VAPTAG(1));
printf("DEBUG: vappptr = %x constptr = %x nodeptr = %x\n", vapptr, constptr, nodeptr);
printf("DEBUG: FN__95Driver_46_95toplevel = %x : %d\n", FN__95Driver_46_95toplevel, FN__95Driver_46_95toplevel);
printf("DEBUG: CF__95Driver_46_95toplevel = %x : %d \n", CF__95Driver_46_95toplevel, CF__95Driver_46_95toplevel);
printf("DEBUG: FN__95Driver_46_95driver = %x : %d\n", FN__95Driver_46_95driver, FN__95Driver_46_95driver);
printf("DEBUG: WORDSHIFT = %d\n", WORDSHIFT);
printf("DEBUG: WORDSIZE = %d\n", WORDSIZE);
printf("DEBUG: WORDMASK = %d\n", WORDMASK);
printf("DEBUG: NS = %d\n", NS);
printf("DEBUG: ZAP_BIT = %d\n", ZAP_BIT);
printf("DEBUG: 2 + (CodePtr)p = %x\n", (2 + (CodePtr) (GET_FINFO(vapptr))));
printf("DEBUG: (NodePtr *)(2 + (CodePtr)p) = %x\n", ((NodePtr *)(2 + (CodePtr) (GET_FINFO(vapptr)))));
printf("DEBUG: (NodePtr **)(2 + (CodePtr)p) = %x\n", ((NodePtr **)(2 + (CodePtr) (GET_FINFO(vapptr)))));
printf("DEBUG: (*(NodePtr **)(2 + (CodePtr)p)) = %x\n", (*((NodePtr **)(2+(CodePtr)(GET_FINFO(vapptr))))));
printf("DEBUG: Zip = %x\n", (unsigned)(*((NodePtr **)(2+(CodePtr)(GET_FINFO(vapptr))))));
printf("DEBUG: ----------------------------------------------------------\n");
ZAP(nodeptr);
PUSH_STATE;
vapptr = nodeptr;
printf("DEBUG: ----------------------------------------------------------\n");
printf("DEBUG: EXT_HADDRESS = %x\n", EXT_HADDRESS(EXT_FINFO(GET_FINFO(vapptr))));
printf("DEBUG: EXT_FINFO = %x\n", EXT_FINFO(GET_FINFO(vapptr)));
printf("DEBUG: GET_FINFO = %x\n", GET_FINFO(vapptr));
printf("DEBUG: FINFO_CONST = %x\n", FINFO_CONST(GET_FINFO(vapptr)));
printf("DEBUG: VAPTAG = %x : %d\n", VAPTAG(1),VAPTAG(1));
printf("DEBUG: vappptr = %x constptr = %x nodeptr = %x\n", vapptr, constptr, nodeptr);
printf("DEBUG: FN__95Driver_46_95toplevel = %x\n", FN__95Driver_46_95toplevel);
printf("DEBUG: CF__95Driver_46_95toplevel = %x \n", CF__95Driver_46_95toplevel);
printf("DEBUG: FN__95Driver_46_95driver = %x \n", FN__95Driver_46_95driver);
printf("DEBUG: WORDSHIFT = %d\n", WORDSHIFT);
printf("DEBUG: WORDSIZE = %d\n", WORDSIZE);
printf("DEBUG: WORDMASK = %d\n", WORDMASK);
printf("DEBUG: NS = %d\n", NS);
printf("DEBUG: ZAP_BIT = %d\n", ZAP_BIT);
printf("DEBUG: 2 + (CodePtr)p = %x\n", (2 + (CodePtr) (GET_FINFO(vapptr))));
printf("DEBUG: (NodePtr *)(2 + (CodePtr)p) = %x\n", ((NodePtr *)(2 + (CodePtr) (GET_FINFO(vapptr)))));
printf("DEBUG: (NodePtr **)(2 + (CodePtr)p) = %x\n", ((NodePtr **)(2 + (CodePtr) (GET_FINFO(vapptr)))));
printf("DEBUG: (*(NodePtr **)(2 + (CodePtr)p)) = %x\n", (*((NodePtr **)(2+(CodePtr)(GET_FINFO(vapptr))))));
printf("DEBUG: Zip = %x\n", (unsigned)(*((NodePtr **)(2+(CodePtr)(GET_FINFO(vapptr))))));
printf("DEBUG: ----------------------------------------------------------\n");
constptr = VAP_CONST(vapptr);
printf("DEBUG: vappptr = %x constptr = %x\n", vapptr, constptr);
ip = FINFO_CODE(GET_FINFO(vapptr));
TPROF_EVAL;
}
TPROF_EVAL_END;
} Break;
Case(RETURN):
INSTR("return");
nodeptr = *sp++;
UPDATE_VAP(nodeptr);
POP_STATEVP;
Break;
Case(RETURN_EVAL):
return_eval:
INSTR("returneval");
nodeptr = *sp++;
UPDATE_VAP(nodeptr);
POP_STATEVP;
TPROF_RETURN_EVAL;
goto EvalTOS;
#ifdef PROFILE
Case(HEAP_CREATE): { BInfo binfo; binfo.all = 0; binfo.parts.created = year; *hp++ = (Node)binfo.all; Break;}
Case(HEAP_SPACE): *hp++ = 0; Break;
#else
Case(HEAP_CREATE): Break; /* Not used, but need to keep gcc-labels happy */
Case(HEAP_SPACE): Break; /* Not used, but need to keep gcc-labels happy */
#endif
Case(HEAP_OFF_N2): *hp = (Node) (hp-HEAPOFFSET(ip[0])-(HEAPOFFSET(ip[1])<<8)); hp++; ip+=2; Break;
Case(HEAP_OFF_N1): *hp = (Node) (hp-HEAPOFFSET(ip[0])); hp++; ip+=1; Break;
Case(HEAP_OFF_P1): *hp = (Node) (hp+HEAPOFFSET(ip[0])); hp++; ip+=1; Break;
Case(HEAP_OFF_P2): *hp = (Node) (hp+HEAPOFFSET(ip[0])+(HEAPOFFSET(ip[1])<<8)); hp++; ip+=2; Break;
Case(HEAP_CADR_N2): *hp++ = (Node)&constptr[-HEAPOFFSET(ip[0])-(HEAPOFFSET(ip[1])<<8)]; ip+=2; Break;
Case(HEAP_CADR_N1): *hp++ = (Node)&constptr[-HEAPOFFSET(ip[0])]; ip+=1; Break;
Case(HEAP_CADR_P1): *hp++ = (Node)&constptr[ HEAPOFFSET(ip[0])]; ip+=1; Break;
Case(HEAP_CADR_P2): *hp++ = (Node)&constptr[ HEAPOFFSET(ip[0])+(HEAPOFFSET(ip[1])<<8)]; ip+=2; Break;
Case(HEAP_CVAL_N2): *hp++ = (Node) constptr[-HEAPOFFSET(ip[0])-(HEAPOFFSET(ip[1])<<8)]; ip+=2; Break;
Case(HEAP_CVAL_N1): *hp++ = (Node) constptr[-HEAPOFFSET(ip[0])]; ip+=1; printf("DEBUG: HEAP_CVAL_N1\n");
Break;
Case(HEAP_CVAL_IN3):*hp++ = (Node) constptr[ -3]; Break;
Case(HEAP_CVAL_I3): *hp++ = (Node) constptr[ 3]; Break;
Case(HEAP_CVAL_I4): *hp++ = (Node) constptr[ 4]; Break;
Case(HEAP_CVAL_I5): *hp++ = (Node) constptr[ 5]; Break;
Case(HEAP_CVAL_P1): *hp++ = (Node) constptr[ HEAPOFFSET(ip[0])]; ip+=1; Break;
Case(HEAP_CVAL_P2): *hp++ = (Node) constptr[ HEAPOFFSET(ip[0])+(HEAPOFFSET(ip[1])<<8)]; ip+=2; Break;
Case(HEAP_INT_N1): *hp++ = (Node) GET_INT(-HEAPOFFSET(ip[0])) ; ip+=1; Break;
Case(HEAP_INT_P1): *hp++ = (Node) GET_INT( HEAPOFFSET(ip[0])) ; ip+=1; Break;
Case(HEAP_CHAR_N1): *hp++ = (Node) GET_CHAR(-HEAPOFFSET(ip[0])) ; ip+=1; Break;
Case(HEAP_CHAR_P1): *hp++ = (Node) GET_CHAR( HEAPOFFSET(ip[0])) ; ip+=1; Break;
Case(HEAP_ARG): UPDATE_PROFINFO(vapptr);
*hp++ = (Node) GET_POINTER_ARG1(vapptr,ip[0]); ip+=1; Break;
Case(HEAP_ARG_ARG): UPDATE_PROFINFO(vapptr);
*hp++ = (Node) GET_POINTER_ARG1(vapptr,ip[0]);
*hp++ = (Node) GET_POINTER_ARG1(vapptr,ip[1]); ip+=2; Break;
Case(HEAP_ARG_ARG_RET_EVAL): UPDATE_PROFINFO(vapptr);
*hp++ = (Node) GET_POINTER_ARG1(vapptr,ip[0]);
*hp++ = (Node) GET_POINTER_ARG1(vapptr,ip[1]); ip+=2;
goto return_eval;
Case(HEAP_I1): nodeptr = sp[ 1 ]; *hp++ = (Node)nodeptr; Break;
Case(HEAP_I2): nodeptr = sp[ 2 ]; *hp++ = (Node)nodeptr; Break;
Case(HEAP_P1): nodeptr = sp[HEAPOFFSET(ip[0])]; *hp++ = (Node)nodeptr; ip+=1; Break;
Case(HEAP_P2): nodeptr = sp[HEAPOFFSET(ip[0])+(HEAPOFFSET(ip[1])<<8)]; *hp++ = (Node)nodeptr; ip+=1; Break;
#define PRIM_OP2_INT(op) \
{ NodePtr nodeptr = *sp++; \
Int a,b; \
IND_REMOVE(nodeptr); ASSERT_W(ip,nodeptr) UPDATE_PROFINFO(nodeptr) a = GET_INT_VALUE(nodeptr); \
nodeptr = *sp++; \
IND_REMOVE(nodeptr); ASSERT_W(ip,nodeptr) UPDATE_PROFINFO(nodeptr) b = GET_INT_VALUE(nodeptr); \
MK_INT(hp, a op b); \
INIT_PROFINFO(hp,&int2ProfInfo) \
*--sp = hp; hp += SIZE_INT; \
} Break
Case(ADD_W): PRIM_OP2_INT(+);
Case(SUB_W): PRIM_OP2_INT(-);
Case(MUL_W): PRIM_OP2_INT(*);
Case(QUOT): PRIM_OP2_INT(/);
Case(REM): PRIM_OP2_INT(%);
Case(NEG_W):
{ NodePtr nodeptr = *sp++;
Int a;
IND_REMOVE(nodeptr); ASSERT_W(ip,nodeptr) UPDATE_PROFINFO(nodeptr) a = GET_INT_VALUE(nodeptr);
MK_INT(hp, -a);
INIT_PROFINFO(hp,&int1ProfInfo)
*--sp = hp; hp += SIZE_INT;
} Break;
Case(ABS_W):
{ NodePtr nodeptr = *sp++;
Int a;
IND_REMOVE(nodeptr); ASSERT_W(ip,nodeptr) UPDATE_PROFINFO(nodeptr) a = GET_INT_VALUE(nodeptr);
if (a < 0) {
nodeptr = hp;
MK_INT(hp, -a);
INIT_PROFINFO(hp,&int1ProfInfo)
hp += SIZE_INT;
}
*--sp = nodeptr;
} Break;
Case(SIGNUM_W):
{ NodePtr nodeptr = *sp++;
Int a;
IND_REMOVE(nodeptr); ASSERT_W(ip,nodeptr) UPDATE_PROFINFO(nodeptr) a = GET_INT_VALUE(nodeptr);
if (a < 0) {
nodeptr = GET_INT(-1);
} else if (a == 0) {
nodeptr = GET_INT(0);
} else {
nodeptr = GET_INT(1);
}
*--sp = nodeptr;
} Break;
#define PRIM_CMP2_INT(op) \
{ NodePtr nodeptr = *sp++; \
Int a,b; \
IND_REMOVE(nodeptr); ASSERT_W(ip,nodeptr) UPDATE_PROFINFO(nodeptr) a = GET_INT_VALUE(nodeptr); \
nodeptr = *sp++; \
IND_REMOVE(nodeptr); ASSERT_W(ip,nodeptr) UPDATE_PROFINFO(nodeptr) b = GET_INT_VALUE(nodeptr); \
*--sp = GET_BOOL(a op b); \
} Break
Case(EQ_W): PRIM_CMP2_INT(==);
Case(NE_W): PRIM_CMP2_INT(!=);
Case(LT_W): PRIM_CMP2_INT(<);
Case(LE_W): PRIM_CMP2_INT(<=);
Case(GT_W): PRIM_CMP2_INT(>);
Case(GE_W): PRIM_CMP2_INT(>=);
#ifndef __alpha /* Float is Double on alpha */
#define PRIM_OP2_FLOAT(op) \
{ NodePtr nodeptr = *sp++; \
float a,b; \
IND_REMOVE(nodeptr); ASSERT_F(ip,nodeptr) UPDATE_PROFINFO(nodeptr) a = get_float_value(nodeptr); \
nodeptr = *sp++; \
IND_REMOVE(nodeptr); ASSERT_F(ip,nodeptr) UPDATE_PROFINFO(nodeptr) b = get_float_value(nodeptr); \
mk_float(hp, a op b); \
INIT_PROFINFO(hp,&float2ProfInfo) \
*--sp = hp; hp += SIZE_FLOAT; \
} Break
Case(ADD_F): PRIM_OP2_FLOAT(+);
Case(SUB_F): PRIM_OP2_FLOAT(-);
Case(MUL_F): PRIM_OP2_FLOAT(*);
Case(SLASH_F): PRIM_OP2_FLOAT(/);
Case(POW_F):
{ NodePtr nodeptr = *sp++;
float a,b;
IND_REMOVE(nodeptr); ASSERT_F(ip,nodeptr) UPDATE_PROFINFO(nodeptr) a = get_float_value(nodeptr);
nodeptr = *sp++;
IND_REMOVE(nodeptr); ASSERT_F(ip,nodeptr) UPDATE_PROFINFO(nodeptr) b = get_float_value(nodeptr);
mk_float(hp, (float)pow((double)a,(double)b));
INIT_PROFINFO(hp,&float2ProfInfo)
*--sp = hp; hp += SIZE_FLOAT;
} Break;
#define PRIM_OP1_FLOAT(op) \
{ NodePtr nodeptr = *sp++; \
float a; \
IND_REMOVE(nodeptr); ASSERT_F(ip,nodeptr) UPDATE_PROFINFO(nodeptr) a = get_float_value(nodeptr); \
mk_float(hp, op); \
INIT_PROFINFO(hp,&float1ProfInfo) \
*--sp = hp; hp += SIZE_FLOAT; \
} Break
Case(NEG_F): PRIM_OP1_FLOAT(-a);
Case(ABS_F): PRIM_OP1_FLOAT((a<0?-a:a));
Case(SIGNUM_F): PRIM_OP1_FLOAT((a<0?-1.0:(a==0?0.0:1.0)));
Case(EXP_F): PRIM_OP1_FLOAT((float)exp((double)a));
Case(LOG_F):PRIM_OP1_FLOAT((float)log((double)a));
Case(SQRT_F):PRIM_OP1_FLOAT((float)sqrt((double)a));
Case(SIN_F):PRIM_OP1_FLOAT((float)sin((double)a));
Case(COS_F):PRIM_OP1_FLOAT((float)cos((double)a));
Case(TAN_F):PRIM_OP1_FLOAT((float)tan((double)a));
Case(ASIN_F):PRIM_OP1_FLOAT((float)asin((double)a));
Case(ACOS_F):PRIM_OP1_FLOAT((float)acos((double)a));
Case(ATAN_F):PRIM_OP1_FLOAT((float)atan((double)a));
#define PRIM_CMP2_FLOAT(op) \
{ NodePtr nodeptr = *sp++; \
float a,b; \
IND_REMOVE(nodeptr); ASSERT_F(ip,nodeptr) UPDATE_PROFINFO(nodeptr) a = get_float_value(nodeptr); \
nodeptr = *sp++; \
IND_REMOVE(nodeptr); ASSERT_F(ip,nodeptr) UPDATE_PROFINFO(nodeptr) b = get_float_value(nodeptr); \
*--sp = GET_BOOL(a op b); \
} Break
Case(EQ_F): PRIM_CMP2_FLOAT(==);
Case(NE_F): PRIM_CMP2_FLOAT(!=);
Case(LT_F): PRIM_CMP2_FLOAT(<);
Case(LE_F): PRIM_CMP2_FLOAT(<=);
Case(GT_F): PRIM_CMP2_FLOAT(>);
Case(GE_F): PRIM_CMP2_FLOAT(>=);
#endif /* __alpha */
#define PRIM_OP2_DOUBLE(op) \
{ NodePtr nodeptr = *sp++; \
double a,b; \
IND_REMOVE(nodeptr); ASSERT_D(ip,nodeptr) UPDATE_PROFINFO(nodeptr) a = get_double_value(nodeptr); \
nodeptr = *sp++; \
IND_REMOVE(nodeptr); ASSERT_D(ip,nodeptr) UPDATE_PROFINFO(nodeptr) b = get_double_value(nodeptr); \
mk_double(hp, a op b); \
INIT_PROFINFO(hp,&double2ProfInfo) \
*--sp = hp; hp += SIZE_DOUBLE; \
} Break
Case(ADD_D): PRIM_OP2_DOUBLE(+);
Case(SUB_D): PRIM_OP2_DOUBLE(-);
Case(MUL_D): PRIM_OP2_DOUBLE(*);
Case(SLASH_D): PRIM_OP2_DOUBLE(/);
Case(POW_D):
{ NodePtr nodeptr = *sp++;
double a,b;
IND_REMOVE(nodeptr); ASSERT_D(ip,nodeptr) UPDATE_PROFINFO(nodeptr) a = get_double_value(nodeptr);
nodeptr = *sp++;
IND_REMOVE(nodeptr); ASSERT_D(ip,nodeptr) UPDATE_PROFINFO(nodeptr) b = get_double_value(nodeptr);
mk_double(hp, pow(a,b));
INIT_PROFINFO(hp,&double2ProfInfo)
*--sp = hp; hp += SIZE_DOUBLE;
} Break;
#define PRIM_OP1_DOUBLE(op) \
{ NodePtr nodeptr = *sp++; \
double a; \
IND_REMOVE(nodeptr); ASSERT_D(ip,nodeptr) UPDATE_PROFINFO(nodeptr) a = get_double_value(nodeptr); \
mk_double(hp, op); \
INIT_PROFINFO(hp,&double1ProfInfo) \
*--sp = hp; hp += SIZE_DOUBLE; \
} Break
Case(NEG_D): PRIM_OP1_DOUBLE(-a);
Case(ABS_D): PRIM_OP1_DOUBLE((a<0?-a:a));
Case(SIGNUM_D): PRIM_OP1_DOUBLE((a<0?-1.0:(a==0?0.0:1.0)));
Case(EXP_D): PRIM_OP1_DOUBLE(exp(a));
Case(LOG_D):PRIM_OP1_DOUBLE(log(a));
Case(SQRT_D):PRIM_OP1_DOUBLE(sqrt(a));
Case(SIN_D):PRIM_OP1_DOUBLE(sin(a));
Case(COS_D):PRIM_OP1_DOUBLE(cos(a));
Case(TAN_D):PRIM_OP1_DOUBLE(tan(a));
Case(ASIN_D):PRIM_OP1_DOUBLE(asin(a));
Case(ACOS_D):PRIM_OP1_DOUBLE(acos(a));
Case(ATAN_D):PRIM_OP1_DOUBLE(atan(a));
#define PRIM_CMP2_DOUBLE(op) \
{ NodePtr nodeptr = *sp++; \
double a,b; \
IND_REMOVE(nodeptr); ASSERT_D(ip,nodeptr) UPDATE_PROFINFO(nodeptr) a = get_double_value(nodeptr); \
nodeptr = *sp++; \
IND_REMOVE(nodeptr); ASSERT_D(ip,nodeptr) UPDATE_PROFINFO(nodeptr) b = get_double_value(nodeptr); \
*--sp = GET_BOOL(a op b); \
} Break
Case(EQ_D): PRIM_CMP2_DOUBLE(==);
Case(NE_D): PRIM_CMP2_DOUBLE(!=);
Case(LT_D): PRIM_CMP2_DOUBLE(<);
Case(LE_D): PRIM_CMP2_DOUBLE(<=);
Case(GT_D): PRIM_CMP2_DOUBLE(>);
Case(GE_D): PRIM_CMP2_DOUBLE(>=);
Case(ORD):
{ UInt tag;
nodeptr = sp[0];
IND_REMOVE(nodeptr);
UPDATE_PROFINFO(nodeptr)
tag = (UInt)GET_CONSTR(nodeptr);
MK_INT(hp,tag);
INIT_PROFINFO(hp,&fromEnumProfInfo)
sp[0] = hp;
hp+= SIZE_INT;
} Break;
Case(CHR):
{ UInt tag;
nodeptr = sp[0];
IND_REMOVE(nodeptr);
UPDATE_PROFINFO(nodeptr)
tag = (UInt)GET_INT_VALUE(nodeptr);
MK_ENUM(hp,tag);
INIT_PROFINFO(hp,&toEnumProfInfo)
sp[0] = hp;
hp+= SIZE_ENUM;
} Break;
Case(STRING):
{ char *str;
nodeptr = *sp++;
IND_REMOVE(nodeptr);
UPDATE_PROFINFO(nodeptr)
str = (char *)GET_INT_VALUE(nodeptr);
if (*str) {
if(*str == '\\')
str++;
MK_INT(hp,(UInt)(str+1));
INIT_PROFINFO(hp,&string1ProfInfo)
nodeptr = hp;
hp += SIZE_INT;
MK_VAP1(hp
,(Node)(C_VAPTAG(PRIM_STRING))
,(Node)nodeptr);
INIT_PROFINFO(hp,&string2ProfInfo)
nodeptr = hp;
hp += SIZE_VAP1;
MK_CONS(hp
,(Node)GET_INT(0xff&(Int)(*str))
,(Node)nodeptr);
INIT_PROFINFO(hp,&string3ProfInfo)
nodeptr = hp;
hp += SIZE_CONS;
} else {
nodeptr = GET_NIL();
}
*--sp = nodeptr;
} Break;
Case(HGETS): /* added MW 2001.02.06 for improved(?) input speed */
{
int c;
/* ForeignObj *fo; */
FileDesc *a;
nodeptr = *sp++;
IND_REMOVE(nodeptr);
UPDATE_PROFINFO(nodeptr)
a = derefForeignObj((ForeignObj*)(GET_INT_VALUE(nodeptr)));
/* fo = (ForeignObj*)(GET_INT_VALUE(nodeptr)); */
/* a = derefForeignObj(fo); */
#ifdef PROFILE
if(replay) {
if(255==(c=getc(inputFILE)))
if(0==(c=getc(inputFILE))) c = -1;
} else
#endif
c = getc(a->fp);
#ifdef PROFILE
if(record) {
if(c==EOF) {
putc(255,inputFILE);
putc(0,inputFILE);
} if (c==255) {
putc(255,inputFILE);
putc(255,inputFILE);
} else
putc(c,inputFILE);
}
#endif
SHOW(fprintf(stderr,"HGETS: c=%d '%c'\n",c,c);)
if (c==-1) {
nodeptr = GET_NIL();
} else {
/* MK_CDATA1(hp,(UInt)(fo)); */
/* INIT_PROFINFO(hp,&handleProfInfo) */
/* nodeptr = hp; */
/* hp += SIZE_INT; */
MK_VAP1(hp
,(Node)(C_VAPTAG(PRIM_HGETS))
,(Node)nodeptr);
INIT_PROFINFO(hp,&inpStringProfInfo)
nodeptr = hp;
hp += SIZE_VAP1;
MK_CONS(hp
,(Node)GET_CHAR(c)
,(Node)nodeptr);
INIT_PROFINFO(hp,&string3ProfInfo)
nodeptr = hp;
hp += SIZE_CONS;
}
*--sp = nodeptr;
} Break;
Case(HGETC):
{
int c;
FileDesc *a;
nodeptr = *sp;
IND_REMOVE(nodeptr);
UPDATE_PROFINFO(nodeptr)
a = derefForeignObj((ForeignObj*)(GET_INT_VALUE(nodeptr)));
#ifdef PROFILE
if(replay) {
if(255==(c=getc(inputFILE)))
if(0==(c=getc(inputFILE))) c = -1;
} else
#endif
c = getc(a->fp);
#ifdef PROFILE
if(record) {
if(c==EOF) {
putc(255,inputFILE);
putc(0,inputFILE);
} if (c==255) {
putc(255,inputFILE);
putc(255,inputFILE);
} else
putc(c,inputFILE);
}
#endif
*sp = GET_CHAR(c); /* Note EOF == -1 == negative character, */
/* but it's OK characters are ints anyway, */
/* and the table includes -1. */
} Break;
Case(HPUTC):
{
char c;
FileDesc *a;
nodeptr = *sp++;
IND_REMOVE(nodeptr);
UPDATE_PROFINFO(nodeptr)
a = derefForeignObj((ForeignObj *)GET_INT_VALUE(nodeptr));
nodeptr = *sp;
IND_REMOVE(nodeptr);
UPDATE_PROFINFO(nodeptr)
c = GET_CHAR_VALUE(nodeptr);
#ifdef PROFILE
if(!replay)
#endif
putc(c,a->fp);
*sp = HPUTC_OK;
} Break;
Case(EXIT):
INSTR("exit");
goto mutator_end;
Break;
Case(TABLESWITCH): /* DAVID */
nodeptr = sp[0];
IND_REMOVE(nodeptr);
UPDATE_PROFINFO(nodeptr)
switch(GET_LARGETAG(nodeptr)) {
case CON_DATA | CON_TAG :
case CON_CDATA | CON_TAG :
nodeptr = (NodePtr) GET_CONSTR(nodeptr);
break;
case CON_PTRS | CON_TAG :
case CON_WORDS | CON_TAG :
nodeptr = 0;
break;
default :
fprintf(stderr,"Trying to get tag from unevaluated node in TABLESWITCH at %p!\n",ip-1);
fprintf(stderr,"Node is:\n");
DUMP_NODE(nodeptr);
exit(-1);
break;
}
ip = (CodePtr) ALIGNPTR2(ip+1);
ip += *(((short*) ip) + (int) nodeptr);
Break;
Case(LOOKUPSWITCH): /* DAVID */
{ int sz = *ip;
short* t;
nodeptr = sp[0];
IND_REMOVE(nodeptr);
UPDATE_PROFINFO(nodeptr)
nodeptr = (NodePtr) GET_INT_VALUE(nodeptr);
ip = (CodePtr) ALIGNPTR2(ip+1);
for (t = (short*) ip; sz > 0; t = t + 2, sz--) {
if (((int) nodeptr) == *t) {
ip += *(t+1);
goto NextInst;
}
}
ip += *t;
}
Break;
Case(MKIORETURN): /* MW - now obsolete */
INSTR("mkIOreturn");
printf("mutator:MKIORETURN\n");
#if 0
nodeptr = *sp;
MK_VAP1(hp,C_VAPTAG(IORETURN),nodeptr); /* Build a call to IO.return */
INIT_PROFINFO(hp,&apply1ProfInfo)
*sp = hp;
hp += SIZE_VAP1;
#endif
Break;
Case(ENDCODE):
INSTR("endcode");
fprintf(stderr,"Tried to evaluate beyond end of function.\n");
fprintf(stderr,"Instruction pointer at %lx\n",(UInt)&ip[-1]);
goto mutator_end;
Break;
UNUSED_INSTRUCTIONS /* MW */
fprintf(stderr,"Unimplemented instruction %d at %lx\n",ip[-1], (UInt)&ip[-1]);
exit(-1);
#if !defined(USE_GCC_LABELS)
default:
fprintf(stderr,"Unknown instruction %d at %lx\n",ip[-1], (UInt)&ip[-1]);
exit(-1);
#endif
EndDispatch
}
mutator_end:
Hp = hp;
Sp = sp;
Fp = fp;
return;
}
#if PROFILE
int sizeofNode(Node tag) {
switch (EXT_TAG(tag)) {
case VAP_TAG0:
case VAP_TAG1:
{ Cinfo cinfo = EXT_CINFO(tag);
int size = (int)CINFO_SIZE(cinfo);
return size+1;
}
case CON_TAG:
{ if (tag == CONSTR(42,0,0))
return 1;
else {
fprintf(stderr,"CON_TAG in sizeofNode!\n");
exit(-1);
return 0;
}
}
default:
{ fprintf(stderr,"IND_TAG in sizeofNode!\n");
exit(-1);
return 0;
}
}
}
#endif
#if defined(BYTECODE_PROF) || (defined(DEBUG) && USE_GCC_LABELS)
# undef ins
static char *instr_names[] = {
"DUMMY_FOR_ZERO",
"NEEDHEAP_P1",
"NEEDHEAP_P2",
"JUMP",
"JUMPFALSE",
"NOP",
"PUSH_CADR_N2",
"PUSH_CADR_N1",
"PUSH_CADR_P1",
"PUSH_CADR_P2",
"PUSH_CVAL_N2",
"PUSH_CVAL_N1",
"PUSH_CVAL_P1",
"PUSH_CVAL_P2",
"PUSH_INT_N2",
"PUSH_INT_N1",
"PUSH_INT_P1",
"PUSH_INT_P2",
"PUSH_ARG",
"PUSH_P1",
"PUSH_P2",
"POP_P1",
"POP_P2",
"SLIDE_P1",
"SLIDE_P2",
"UNPACK",
"APPLY",
"EVAL",
"RETURN",
"RETURN_EVAL",
"HEAP_CADR_N2",
"HEAP_CADR_N1",
"HEAP_CADR_P1",
"HEAP_CADR_P2",
"HEAP_CVAL_N2",
"HEAP_CVAL_N1",
"HEAP_CVAL_P1",
"HEAP_CVAL_P2",
"HEAP_INT_N2",
"HEAP_INT_N1",
"HEAP_INT_P1",
"HEAP_INT_P2",
"HEAP_ARG",
"HEAP_ARG_ARG",
"HEAP_ARG_ARG_RET_EVAL",
"HEAP_P1",
"HEAP_P2",
"ADD_W",
"ADD_F",
"ADD_D",
"SUB_W",
"SUB_F",
"SUB_D",
"MUL_W",
"MUL_F",
"MUL_D",
"ABS_W",
"ABS_F",
"ABS_D",
"SIGNUM_W",
"SIGNUM_F",
"SIGNUM_D",
"EXP_F",
"EXP_D",
"LOG_F",
"LOG_D",
"SQRT_F",
"SQRT_D",
"SIN_F",
"SIN_D",
"COS_F",
"COS_D",
"TAN_F",
"TAN_D",
"ASIN_F",
"ASIN_D",
"ACOS_F",
"ACOS_D",
"ATAN_F",
"ATAN_D",
"SLASH_F",
"SLASH_D",
"EQ_W",
"EQ_F",
"EQ_D",
"NE_W",
"NE_F",
"NE_D",
"LT_W",
"LT_F",
"LT_D",
"LE_W",
"LE_F",
"LE_D",
"GT_W",
"GT_F",
"GT_D",
"GE_W",
"GE_F",
"GE_D",
"NEG_W",
"NEG_F",
"NEG_D",
"QUOT",
"REM",
"AND",
"OR",
"NOT",
"ORD",
"CHR",
"SEQ",
"STRING",
"PRIMITIVE",
"PUSH_HEAP",
"EXIT",
"NEEDSTACK_P1",
"NEEDSTACK_P2",
"HEAP_OFF_N2",
"HEAP_OFF_N1",
"HEAP_OFF_P1",
"HEAP_OFF_P2",
"HEAP_CREATE",
"HEAP_SPACE",
"SELECTOR_EVAL",
"SELECT",
"ZAP_ARG",
"ZAP_STACK_P1",
"ZAP_STACK_P2",
"NEEDHEAP_I32",
"NEEDSTACK_I16",
"PUSH_I1",
"POP_I1",
"PUSH_ARG_I1",
"PUSH_ARG_I2",
"PUSH_ARG_I3",
"ZAP_ARG_I1",
"ZAP_ARG_I2",
"ZAP_ARG_I3",
"HEAP_CVAL_I3",
"HEAP_CVAL_I4",
"HEAP_CVAL_I5",
"HEAP_CVAL_IN3",
"HEAP_I1",
"HEAP_I2",
"HPUTC",
"HGETC",
"HGETS",
"PUSH_CHAR_N1",
"PUSH_CHAR_P1",
"HEAP_CHAR_N1",
"HEAP_CHAR_P1",
"TABLESWITCH",
"LOOKUPSWITCH",
"MKIORETURN",
"PUSH_ZAP_ARG_I1",
"PUSH_ZAP_ARG_I2",
"PUSH_ZAP_ARG_I3",
"PUSH_ZAP_ARG",
"ENDCODE",
"POW_F",
"POW_D"
};
#endif
#ifdef BYTECODE_PROF
#if PAIR
void instr_prof_init() {
int i,j;
for (i=1; i<=ENDCODE; i++) {
for (j=1; j<=ENDCODE; j++) {
instr_pair[i][j] = 0;
}
}
}
void instr_prof_results() {
int i,j;
fprintf(stderr,"Instruction pairs.\n");
for (i=1; i<=ENDCODE; i++) {
for (j=1; j<=ENDCODE; j++) {
if (instr_pair[i][j]) {
fprintf(stderr,"(%3d,%3d) %9d\t%s..%s\n",i,j,
instr_pair[i][j],
instr_names[i],instr_names[j]);
}
}
}
fprintf(stderr,"\nTotal instruction count = %d\n",total_instr_count);
}
#else
void instr_prof_init() {
int i,j,k;
for (i=1; i<=ENDCODE; i++) {
for (j=1; j<=ENDCODE; j++) {
for (k=1; k<=ENDCODE; k++) {
instr_triple[i][j][k] = 0;
}
}
}
}
void instr_prof_results() {
int i,j,k;
fprintf(stderr,"Instruction triples.\n");
for (i=1; i<=ENDCODE; i++) {
for (j=1; j<=ENDCODE; j++) {
for (k=1; k<=ENDCODE; k++) {
if (instr_triple[i][j][k]) {
fprintf(stderr,"(%3d,%3d,%3d) %9d\t%s..%s..%s\n",i,j,k,
instr_triple[i][j][k],
instr_names[i],instr_names[j],instr_names[k]);
}
}
}
}
fprintf(stderr,"\nTotal instruction count = %d\n",total_instr_count);
}
#endif /*PAIR*/
#endif /*BYTECODE_PROF*/
|
