--- gforth/engine/engine.c 2002/12/19 20:43:26 1.49
+++ gforth/engine/engine.c 2005/08/21 22:09:14 1.84
@@ -1,6 +1,6 @@
/* Gforth virtual machine (aka inner interpreter)
- Copyright (C) 1995,1996,1997,1998,2000 Free Software Foundation, Inc.
+ Copyright (C) 1995,1996,1997,1998,2000,2003,2004 Free Software Foundation, Inc.
This file is part of Gforth.
@@ -19,7 +19,12 @@
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
*/
-undefine(`symbols')
+#if defined(GFORTH_DEBUGGING) || defined(INDIRECT_THREADED) || defined(DOUBLY_INDIRECT) || defined(VM_PROFILING)
+#define USE_NO_TOS
+#else
+#define USE_TOS
+#endif
+#define USE_NO_FTOS
#include "config.h"
#include "forth.h"
@@ -61,28 +66,27 @@ undefine(`symbols')
#include
#endif
+#ifdef HAS_FFCALL
+#include
+#include
+#endif
+
+#ifdef HAS_LIBFFI
+#include
+#endif
+
#ifndef SEEK_SET
/* should be defined in stdio.h, but some systems don't have it */
#define SEEK_SET 0
#endif
-#define IOR(flag) ((flag)? -512-errno : 0)
-
-struct F83Name {
- struct F83Name *next; /* the link field for old hands */
- char countetc;
- char name[0];
-};
-
-#define F83NAME_COUNT(np) ((np)->countetc & 0x1f)
-
-struct Longname {
- struct Longname *next; /* the link field for old hands */
- Cell countetc;
- char name[0];
-};
+#ifndef HAVE_FSEEKO
+#define fseeko fseek
+#endif
-#define LONGNAME_COUNT(np) ((np)->countetc & (((~((UCell)0))<<3)>>3))
+#ifndef HAVE_FTELLO
+#define ftello ftell
+#endif
#define NULLC '\0'
@@ -151,6 +155,9 @@ extern int gforth_memcmp(const char * s1
#ifndef LPREG
#define LPREG
#endif
+#ifndef CAREG
+#define CAREG
+#endif
#ifndef CFAREG
#define CFAREG
#endif
@@ -160,6 +167,27 @@ extern int gforth_memcmp(const char * s1
#ifndef TOSREG
#define TOSREG
#endif
+#ifndef spbREG
+#define spbREG
+#endif
+#ifndef spcREG
+#define spcREG
+#endif
+#ifndef spdREG
+#define spdREG
+#endif
+#ifndef speREG
+#define speREG
+#endif
+#ifndef spfREG
+#define spfREG
+#endif
+#ifndef spgREG
+#define spgREG
+#endif
+#ifndef sphREG
+#define sphREG
+#endif
#ifndef FTOSREG
#define FTOSREG
#endif
@@ -168,7 +196,7 @@ extern int gforth_memcmp(const char * s1
# define CPU_DEP1 0
#endif
-/* instructions containing these must be the last instruction of a
+/* instructions containing SUPER_END must be the last instruction of a
super-instruction (e.g., branches, EXECUTE, and other instructions
ending the basic block). Instructions containing SET_IP get this
automatically, so you usually don't have to write it. If you have
@@ -182,6 +210,23 @@ extern int gforth_memcmp(const char * s1
#endif
#define SUPER_CONTINUE
+#ifdef GFORTH_DEBUGGING
+#if DEBUG
+#define NAME(string) { saved_ip=ip; asm("# "string); fprintf(stderr,"%08lx depth=%3ld: "string"\n",(Cell)ip,sp0+3-sp);}
+#else /* !DEBUG */
+#define NAME(string) { saved_ip=ip; asm(""); }
+/* the asm here is to avoid reordering of following stuff above the
+ assignment; this is an old-style asm (no operands), and therefore
+ is treated like "asm volatile ..."; i.e., it prevents most
+ reorderings across itself. We want the assignment above first,
+ because the stack loads may already cause a stack underflow. */
+#endif /* !DEBUG */
+#elif DEBUG
+# define NAME(string) {Cell __depth=sp0+3-sp; int i; fprintf(stderr,"%08lx depth=%3ld: "string,(Cell)ip,sp0+3-sp); for (i=__depth-1; i>0; i--) fprintf(stderr, " $%lx",sp[i]); fprintf(stderr, " $%lx\n",spTOS); }
+#else
+# define NAME(string) asm("# "string);
+#endif
+
#ifdef DEBUG
#define CFA_TO_NAME(__cfa) \
Cell len, i; \
@@ -196,8 +241,42 @@ extern int gforth_memcmp(const char * s1
}
#endif
-define(enginerest,
-`(Xt *ip0, Cell *sp0, Cell *rp0, Float *fp0, Address lp0)
+#ifdef HAS_FFCALL
+#define SAVE_REGS IF_fpTOS(fp[0]=fpTOS); SP=sp; FP=fp; RP=rp; LP=lp;
+#define REST_REGS sp=SP; fp=FP; rp=RP; lp=LP; IF_fpTOS(fpTOS=fp[0]);
+#endif
+
+#if !defined(ENGINE)
+/* normal engine */
+#define VARIANT(v) (v)
+#define JUMP(target) goto I_noop
+#define LABEL(name) H_##name: asm(""); I_##name:
+
+#elif ENGINE==2
+/* variant with padding between VM instructions for finding out
+ cross-inst jumps (for dynamic code) */
+#define engine engine2
+#define VARIANT(v) (v)
+#define JUMP(target) goto I_noop
+#define LABEL(name) H_##name: SKIP16; I_##name:
+#define IN_ENGINE2
+
+#elif ENGINE==3
+/* variant with different immediate arguments for finding out
+ immediate arguments (for native code) */
+#define engine engine3
+#define VARIANT(v) ((v)^0xffffffff)
+#define JUMP(target) goto K_lit
+#define LABEL(name) H_##name: asm(""); I_##name:
+#else
+#error illegal ENGINE value
+#endif /* ENGINE */
+
+/* the asm(""); is there to get a stop compiled on Itanium */
+#define LABEL2(name) K_##name: asm("");
+#define LABEL3(name) J_##name: asm("");
+
+Label *engine(Xt *ip0, Cell *sp0, Cell *rp0, Float *fp0, Address lp0)
/* executes code at ip, if ip!=NULL
returns array of machine code labels (for use in a loader), if ip==NULL
*/
@@ -212,11 +291,33 @@ define(enginerest,
register Float *fp FPREG = fp0;
register Address lp LPREG = lp0;
register Xt cfa CFAREG;
+ register Label real_ca CAREG;
#ifdef MORE_VARS
MORE_VARS
#endif
+#ifdef HAS_FFCALL
+ av_alist alist;
+ extern va_alist clist;
+ float frv;
+ int irv;
+ double drv;
+ long long llrv;
+ void * prv;
+#endif
+#ifdef HAS_LIBFFI
+ extern void * ritem;
+ extern void ** clist;
+ extern void ffi_callback(ffi_cif * cif, void * resp, void ** args, Xt * ip);
+#endif
register Address up UPREG = UP;
- IF_spTOS(register Cell spTOS TOSREG;)
+ register Cell MAYBE_UNUSED spTOS TOSREG;
+ register Cell MAYBE_UNUSED spb spbREG;
+ register Cell MAYBE_UNUSED spc spcREG;
+ register Cell MAYBE_UNUSED spd spdREG;
+ register Cell MAYBE_UNUSED spe speREG;
+ register Cell MAYBE_UNUSED spf speREG;
+ register Cell MAYBE_UNUSED spg speREG;
+ register Cell MAYBE_UNUSED sph speREG;
IF_fpTOS(register Float fpTOS FTOSREG;)
#if defined(DOUBLY_INDIRECT)
static Label *symbols;
@@ -226,29 +327,23 @@ define(enginerest,
static Label symbols[]= {
#define MAX_SYMBOLS (sizeof(symbols)/sizeof(symbols[0]))
#endif /* !defined(DOUBLY_INDIRECT) */
- (Label)&&docol,
- (Label)&&docon,
- (Label)&&dovar,
- (Label)&&douser,
- (Label)&&dodefer,
- (Label)&&dofield,
- (Label)&&dodoes,
- /* the following entry is normally unused;
- it is there because its index indicates a does-handler */
- CPU_DEP1,
-#define INST_ADDR(name) (Label)&&I_##name
-#include "prim_lab.i"
+#define INST_ADDR(name) ((Label)&&I_##name)
+#include PRIM_LAB_I
#undef INST_ADDR
- (Label)&&after_last,
(Label)0,
-#define INST_ADDR(name) (Label)&&K_##name
-#include "prim_lab.i"
+#define INST_ADDR(name) ((Label)&&K_##name)
+#include PRIM_LAB_I
#undef INST_ADDR
-#ifdef IN_ENGINE2
-#define INST_ADDR(name) (Label)&&J_##name
-#include "prim_lab.i"
+#define INST_ADDR(name) ((Label)&&J_##name)
+#include PRIM_LAB_I
+#undef INST_ADDR
+ (Label)&&after_last,
+ (Label)&&before_goto,
+ (Label)&&after_goto,
+/* just mention the H_ labels, so the SKIP16s are not optimized away */
+#define INST_ADDR(name) ((Label)&&H_##name)
+#include PRIM_LAB_I
#undef INST_ADDR
-#endif
};
#ifdef CPU_DEP2
CPU_DEP2
@@ -275,7 +370,7 @@ define(enginerest,
xts[i] = symbols[i] = (Label)routines[i];
for (; routines[i]!=0; i++) {
if (i>=MAX_SYMBOLS) {
- fprintf(stderr,"gforth-ditc: more than %d primitives\n",MAX_SYMBOLS);
+ fprintf(stderr,"gforth-ditc: more than %ld primitives\n",(long)MAX_SYMBOLS);
exit(1);
}
xts[i] = symbols[i] = &routines[i];
@@ -284,213 +379,38 @@ define(enginerest,
return symbols;
}
- IF_spTOS(spTOS = sp[0]);
+#if !(defined(GFORTH_DEBUGGING) || defined(INDIRECT_THREADED) || defined(DOUBLY_INDIRECT) || defined(VM_PROFILING))
+ sp += STACK_CACHE_DEFAULT-1;
+ /* some of those registers are dead, but its simpler to initialize them all */ spTOS = sp[0];
+ spb = sp[-1];
+ spc = sp[-2];
+ spd = sp[-3];
+ spe = sp[-4];
+ spf = sp[-5];
+ spg = sp[-6];
+ sph = sp[-7];
+#endif
+
IF_fpTOS(fpTOS = fp[0]);
/* prep_terminal(); */
#ifdef NO_IP
goto *(*(Label *)ip0);
+ before_goto:
+ goto *real_ca;
+ after_goto:;
#else
SET_IP(ip);
SUPER_END; /* count the first block, too */
- NEXT;
+ FIRST_NEXT;
#endif
#ifdef CPU_DEP3
CPU_DEP3
#endif
-
- docol:
- {
-#ifdef NO_IP
- *--rp = next_code;
- goto **(Label *)PFA1(cfa);
-#else
-#ifdef DEBUG
- {
- CFA_TO_NAME(cfa);
- fprintf(stderr,"%08lx: col: %08lx %.*s\n",(Cell)ip,(Cell)PFA1(cfa),
- len,name);
- }
-#endif
-#ifdef CISC_NEXT
- /* this is the simple version */
- *--rp = (Cell)ip;
- SET_IP((Xt *)PFA1(cfa));
- SUPER_END;
- NEXT;
-#else
- /* this one is important, so we help the compiler optimizing */
- {
- DEF_CA
- rp[-1] = (Cell)ip;
- SET_IP((Xt *)PFA1(cfa));
- SUPER_END;
- NEXT_P1;
- rp--;
- NEXT_P2;
- }
-#endif
-#endif
- }
- docon:
- {
-#ifdef DEBUG
- fprintf(stderr,"%08lx: con: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa));
-#endif
-#ifdef USE_TOS
- *sp-- = spTOS;
- spTOS = *(Cell *)PFA1(cfa);
-#else
- *--sp = *(Cell *)PFA1(cfa);
-#endif
- }
-#ifdef NO_IP
- goto *next_code;
-#else
- NEXT_P0;
- NEXT;
-#endif
-
- dovar:
- {
-#ifdef DEBUG
- fprintf(stderr,"%08lx: var: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
-#endif
-#ifdef USE_TOS
- *sp-- = spTOS;
- spTOS = (Cell)PFA1(cfa);
-#else
- *--sp = (Cell)PFA1(cfa);
-#endif
- }
-#ifdef NO_IP
- goto *next_code;
-#else
- NEXT_P0;
- NEXT;
-#endif
-
- douser:
- {
-#ifdef DEBUG
- fprintf(stderr,"%08lx: user: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
-#endif
-#ifdef USE_TOS
- *sp-- = spTOS;
- spTOS = (Cell)(up+*(Cell*)PFA1(cfa));
-#else
- *--sp = (Cell)(up+*(Cell*)PFA1(cfa));
-#endif
- }
-#ifdef NO_IP
- goto *next_code;
-#else
- NEXT_P0;
- NEXT;
-#endif
-
- dodefer:
- {
-#ifdef DEBUG
- fprintf(stderr,"%08lx: defer: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa));
-#endif
- SUPER_END;
- EXEC(*(Xt *)PFA1(cfa));
- }
-
- dofield:
- {
-#ifdef DEBUG
- fprintf(stderr,"%08lx: field: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
-#endif
- spTOS += *(Cell*)PFA1(cfa);
- }
-#ifdef NO_IP
- goto *next_code;
-#else
- NEXT_P0;
- NEXT;
-#endif
-
- dodoes:
- /* this assumes the following structure:
- defining-word:
-
- ...
- DOES>
- (possible padding)
- possibly handler: jmp dodoes
- (possible branch delay slot(s))
- Forth code after DOES>
-
- defined word:
-
- cfa: address of or jump to handler OR
- address of or jump to dodoes, address of DOES-code
- pfa:
-
- */
-#ifdef NO_IP
- *--rp = next_code;
- IF_spTOS(spTOS = sp[0]);
- sp--;
- spTOS = (Cell)PFA(cfa);
- goto **(Label *)DOES_CODE1(cfa);
-#else
- {
- /* fprintf(stderr, "Got CFA %08lx at doescode %08lx/%08lx: does: %08lx\n",cfa,(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa));*/
-#ifdef DEBUG
- fprintf(stderr,"%08lx/%08lx: does: %08lx\n",(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa));
- fflush(stderr);
-#endif
- *--rp = (Cell)ip;
- /* PFA1 might collide with DOES_CODE1 here, so we use PFA */
-#ifdef USE_TOS
- *sp-- = spTOS;
- spTOS = (Cell)PFA(cfa);
-#else
- *--sp = (Cell)PFA(cfa);
-#endif
- SET_IP(DOES_CODE1(cfa));
- SUPER_END;
- /* fprintf(stderr,"TOS = %08lx, IP=%08lx\n", spTOS, IP);*/
- }
- NEXT;
-#endif
-
-#ifndef IN_ENGINE2
-#define LABEL(name) I_##name:
-#else
-#define LABEL(name) J_##name: asm(".skip 16"); I_##name:
-#endif
-#define LABEL2(name) K_##name:
-#include "prim.i"
-#undef LABEL
+#include PRIM_I
after_last: return (Label *)0;
/*needed only to get the length of the last primitive */
-}'
-)
-#define VARIANT(v) (v)
-#define JUMP(target) goto I_noop
-
-Label *engine enginerest
-
-#ifndef NO_DYNAMIC
-
-#ifdef NO_IP
-#undef VARIANT
-#define VARIANT(v) ((v)^0xffffffff)
-#undef JUMP
-#define JUMP(target) goto K_lit
-Label *engine3 enginerest
-#endif
-
-#undef VARIANT
-#define VARIANT(v) (v)
-#undef JUMP
-#define JUMP(target) goto I_noop
-#define IN_ENGINE2
-Label *engine2 enginerest
-#endif
+ return (Label *)0;
+}