Diff for /gforth/engine/engine.c between versions 1.48 and 1.73

version 1.48, 2002/12/19 20:14:57 version 1.73, 2004/01/05 22:25:03
Line 1 Line 1
 /* Gforth virtual machine (aka inner interpreter)  /* 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 Free Software Foundation, Inc.
   
   This file is part of Gforth.    This file is part of Gforth.
   
Line 19 Line 19
   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.    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 "config.h"
 #include "forth.h"  #include "forth.h"
Line 61  undefine(`symbols') Line 66  undefine(`symbols')
 #include <dl.h>  #include <dl.h>
 #endif  #endif
   
   #ifdef HAS_FFCALL
   #include <avcall.h>
   #include <callback.h>
   #endif
   
 #ifndef SEEK_SET  #ifndef SEEK_SET
 /* should be defined in stdio.h, but some systems don't have it */  /* should be defined in stdio.h, but some systems don't have it */
 #define SEEK_SET 0  #define SEEK_SET 0
 #endif  #endif
   
 #define IOR(flag)       ((flag)? -512-errno : 0)  #ifndef HAVE_FSEEKO
   #define fseeko fseek
   #endif
   
 struct F83Name {  #ifndef HAVE_FTELLO
   struct F83Name *next;  /* the link field for old hands */  #define ftello ftell
   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];  
 };  
   
 #define LONGNAME_COUNT(np)      ((np)->countetc & (((~((UCell)0))<<3)>>3))  
   
 Cell *SP;  
 Float *FP;  
 Address UP=NULL;  
   
 #if 0  
 /* not used currently */  
 int emitcounter;  
 #endif  #endif
   
 #define NULLC '\0'  #define NULLC '\0'
   
 #ifdef MEMCMP_AS_SUBROUTINE  #ifdef MEMCMP_AS_SUBROUTINE
Line 101  extern int gforth_memcmp(const char * s1 Line 93  extern int gforth_memcmp(const char * s1
   
 #define NEWLINE '\n'  #define NEWLINE '\n'
   
 #ifdef HAS_FILE  
 static char* fileattr[6]={"rb","rb","r+b","r+b","wb","wb"};  
 static char* pfileattr[6]={"r","r","r+","r+","w","w"};  
   
 #ifndef O_BINARY  
 #define O_BINARY 0  
 #endif  
 #ifndef O_TEXT  
 #define O_TEXT 0  
 #endif  
   
 static int ufileattr[6]= {  
   O_RDONLY|O_BINARY, O_RDONLY|O_BINARY,  
   O_RDWR  |O_BINARY, O_RDWR  |O_BINARY,  
   O_WRONLY|O_BINARY, O_WRONLY|O_BINARY };  
 #endif  
   
 /* conversion on fetch */  /* conversion on fetch */
   
 #define vm_Cell2f(_cell,_x)             ((_x)=(Bool)(_cell))  #define vm_Cell2f(_cell,_x)             ((_x)=(Bool)(_cell))
Line 185  static int ufileattr[6]= { Line 160  static int ufileattr[6]= {
 #ifndef TOSREG  #ifndef TOSREG
 #define TOSREG  #define TOSREG
 #endif  #endif
   #ifndef spaREG
   #define spaREG
   #endif
   #ifndef spbREG
   #define spbREG
   #endif
 #ifndef FTOSREG  #ifndef FTOSREG
 #define FTOSREG  #define FTOSREG
 #endif  #endif
Line 193  static int ufileattr[6]= { Line 174  static int ufileattr[6]= {
 # define CPU_DEP1 0  # define CPU_DEP1 0
 #endif  #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     super-instruction (e.g., branches, EXECUTE, and other instructions
    ending the basic block). Instructions containing SET_IP get this     ending the basic block). Instructions containing SET_IP get this
    automatically, so you usually don't have to write it.  If you have     automatically, so you usually don't have to write it.  If you have
Line 208  static int ufileattr[6]= { Line 189  static int ufileattr[6]= {
 #define SUPER_CONTINUE  #define SUPER_CONTINUE
   
 #ifdef GFORTH_DEBUGGING  #ifdef GFORTH_DEBUGGING
 /* define some VM registers as global variables, so they survive exceptions;  #if DEBUG
    global register variables are not up to the task (according to the   #define NAME(string) { saved_ip=ip; asm("# "string); fprintf(stderr,"%08lx depth=%3ld: "string"\n",(Cell)ip,sp0+3-sp);}
    GNU C manual) */  #else /* !DEBUG */
 Xt *saved_ip;  #define NAME(string) { saved_ip=ip; asm(""); }
 Cell *rp;  /* the asm here is to avoid reordering of following stuff above the
 #endif     assignment; this is an old-style asm (no operands), and therefore
      is treated like "asm volatile ..."; i.e., it prevents most
 #ifdef NO_IP     reorderings across itself.  We want the assignment above first,
 static Label next_code;     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  #endif
   
 #ifdef DEBUG  #ifdef DEBUG
Line 233  static Label next_code; Line 219  static Label next_code;
       }        }
 #endif  #endif
   
 define(enginerest,  #ifdef HAS_FFCALL
 `(Xt *ip0, Cell *sp0, Cell *rp0, Float *fp0, Address lp0)  #define SAVE_REGS IF_spTOS(sp[0]=spTOS); 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_spTOS(spTOS=sp[0]); IF_fpTOS(fpTOS=fp[0]);
   #endif
   
   #if !defined(ENGINE)
   /* normal engine */
   #define VARIANT(v)      (v)
   #define JUMP(target)    goto I_noop
   #define LABEL(name) J_##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) J_##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) J_##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("");
   
   Label *engine(Xt *ip0, Cell *sp0, Cell *rp0, Float *fp0, Address lp0)
 /* executes code at ip, if ip!=NULL  /* executes code at ip, if ip!=NULL
    returns array of machine code labels (for use in a loader), if ip==NULL     returns array of machine code labels (for use in a loader), if ip==NULL
 */  */
Line 252  define(enginerest, Line 271  define(enginerest,
 #ifdef MORE_VARS  #ifdef MORE_VARS
   MORE_VARS    MORE_VARS
 #endif  #endif
   #ifdef HAS_FFCALL
     av_alist alist;
     extern va_alist clist;
     float frv;
     int irv;
     double drv;
     long long llrv;
     void * prv;
   #endif
   register Address up UPREG = UP;    register Address up UPREG = UP;
   IF_spTOS(register Cell spTOS TOSREG;)    IF_spTOS(register Cell MAYBE_UNUSED spTOS TOSREG;)
     register Cell MAYBE_UNUSED spb spaREG;
     register Cell MAYBE_UNUSED spc spbREG;
   IF_fpTOS(register Float fpTOS FTOSREG;)    IF_fpTOS(register Float fpTOS FTOSREG;)
 #if defined(DOUBLY_INDIRECT)  #if defined(DOUBLY_INDIRECT)
   static Label *symbols;    static Label *symbols;
Line 263  define(enginerest, Line 293  define(enginerest,
   static Label symbols[]= {    static Label symbols[]= {
 #define MAX_SYMBOLS (sizeof(symbols)/sizeof(symbols[0]))  #define MAX_SYMBOLS (sizeof(symbols)/sizeof(symbols[0]))
 #endif /* !defined(DOUBLY_INDIRECT) */  #endif /* !defined(DOUBLY_INDIRECT) */
     (Label)&&docol,  #define INST_ADDR(name) ((Label)&&I_##name)
     (Label)&&docon,  #include PRIM_LAB_I
     (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"  
 #undef INST_ADDR  #undef INST_ADDR
     (Label)&&after_last,  
     (Label)0,      (Label)0,
 #define INST_ADDR(name) (Label)&&K_##name  #define INST_ADDR(name) ((Label)&&K_##name)
 #include "prim_lab.i"  #include PRIM_LAB_I
 #undef INST_ADDR  #undef INST_ADDR
 #ifdef IN_ENGINE2  #define INST_ADDR(name) ((Label)&&J_##name)
 #define INST_ADDR(name) (Label)&&J_##name  #include PRIM_LAB_I
 #include "prim_lab.i"  
 #undef INST_ADDR  #undef INST_ADDR
 #endif      (Label)&&after_last
   };    };
 #ifdef CPU_DEP2  #ifdef CPU_DEP2
   CPU_DEP2    CPU_DEP2
Line 312  define(enginerest, Line 330  define(enginerest,
       xts[i] = symbols[i] = (Label)routines[i];        xts[i] = symbols[i] = (Label)routines[i];
     for (; routines[i]!=0; i++) {      for (; routines[i]!=0; i++) {
       if (i>=MAX_SYMBOLS) {        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);          exit(1);
       }        }
       xts[i] = symbols[i] = &routines[i];        xts[i] = symbols[i] = &routines[i];
Line 335  define(enginerest, Line 353  define(enginerest,
 #ifdef CPU_DEP3  #ifdef CPU_DEP3
   CPU_DEP3    CPU_DEP3
 #endif  #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:  #include PRIM_I
   {  
 #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  
   after_last: return (Label *)0;    after_last: return (Label *)0;
   /*needed only to get the length of the last primitive */    /*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  

Removed from v.1.48  
changed lines
  Added in v.1.73


FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>