Diff for /gforth/engine/engine.c between versions 1.52 and 1.76

version 1.52, 2002/12/23 22:14:06 version 1.76, 2005/01/22 21:06: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,2004 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.
 */  */
   
   #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"
 #include <ctype.h>  #include <ctype.h>
Line 59 Line 66
 #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
 struct F83Name {  #endif
   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];  
 };  
   
 #define LONGNAME_COUNT(np)      ((np)->countetc & (((~((UCell)0))<<3)>>3))  #ifndef HAVE_FTELLO
   #define ftello ftell
   #endif
   
 #define NULLC '\0'  #define NULLC '\0'
   
Line 158  extern int gforth_memcmp(const char * s1 Line 160  extern int gforth_memcmp(const char * s1
 #ifndef TOSREG  #ifndef TOSREG
 #define TOSREG  #define TOSREG
 #endif  #endif
   #ifndef spbREG
   #define spbREG
   #endif
   #ifndef spcREG
   #define spcREG
   #endif
 #ifndef FTOSREG  #ifndef FTOSREG
 #define FTOSREG  #define FTOSREG
 #endif  #endif
Line 166  extern int gforth_memcmp(const char * s1 Line 174  extern int gforth_memcmp(const char * s1
 # 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 180  extern int gforth_memcmp(const char * s1 Line 188  extern int gforth_memcmp(const char * s1
 #endif  #endif
 #define SUPER_CONTINUE  #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  #ifdef DEBUG
 #define CFA_TO_NAME(__cfa) \  #define CFA_TO_NAME(__cfa) \
       Cell len, i; \        Cell len, i; \
Line 194  extern int gforth_memcmp(const char * s1 Line 219  extern int gforth_memcmp(const char * s1
       }        }
 #endif  #endif
   
   #ifdef HAS_FFCALL
   #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)  #if !defined(ENGINE)
 /* normal engine */  /* normal engine */
 #define VARIANT(v)      (v)  #define VARIANT(v)      (v)
Line 220  extern int gforth_memcmp(const char * s1 Line 250  extern int gforth_memcmp(const char * s1
 #error illegal ENGINE value  #error illegal ENGINE value
 #endif /* ENGINE */  #endif /* ENGINE */
   
 #define LABEL2(name) K_##name:  /* 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)  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
Line 238  Label *engine(Xt *ip0, Cell *sp0, Cell * Line 268  Label *engine(Xt *ip0, Cell *sp0, Cell *
   register Float *fp FPREG = fp0;    register Float *fp FPREG = fp0;
   register Address lp LPREG = lp0;    register Address lp LPREG = lp0;
   register Xt cfa CFAREG;    register Xt cfa CFAREG;
     register Label real_ca;
 #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 spbREG;
     register Cell MAYBE_UNUSED spc spcREG;
   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 252  Label *engine(Xt *ip0, Cell *sp0, Cell * Line 294  Label *engine(Xt *ip0, Cell *sp0, Cell *
   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
 #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
       (Label)&&after_last,
       (Label)&&before_goto,
       (Label)&&after_goto
   };    };
 #ifdef CPU_DEP2  #ifdef CPU_DEP2
   CPU_DEP2    CPU_DEP2
Line 299  Label *engine(Xt *ip0, Cell *sp0, Cell * Line 333  Label *engine(Xt *ip0, Cell *sp0, Cell *
       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 322  Label *engine(Xt *ip0, Cell *sp0, Cell * Line 356  Label *engine(Xt *ip0, Cell *sp0, Cell *
 #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:  
   {  
 #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:    before_goto:
   /* this assumes the following structure:    goto *real_ca;
      defining-word:    after_goto:
        
      ...  
      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  
   
 #include "prim.i"  #include PRIM_I
   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 */
 }  }

Removed from v.1.52  
changed lines
  Added in v.1.76


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