Diff for /gforth/engine/engine.c between versions 1.12 and 1.39

version 1.12, 1999/05/12 19:30:30 version 1.39, 2002/01/20 19:04:11
Line 1 Line 1
 /* Gforth virtual machine (aka inner interpreter)  /* Gforth virtual machine (aka inner interpreter)
   
   Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.    Copyright (C) 1995,1996,1997,1998,2000 Free Software Foundation, Inc.
   
   This file is part of Gforth.    This file is part of Gforth.
   
Line 16 Line 16
   
   You should have received a copy of the GNU General Public License    You should have received a copy of the GNU General Public License
   along with this program; if not, write to the Free Software    along with this program; if not, write to the Free Software
   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
 */  */
   
   undefine(`symbols')
   
 #include "config.h"  #include "config.h"
   #include "forth.h"
 #include <ctype.h>  #include <ctype.h>
 #include <stdio.h>  #include <stdio.h>
 #include <string.h>  #include <string.h>
Line 27 Line 30
 #include <assert.h>  #include <assert.h>
 #include <stdlib.h>  #include <stdlib.h>
 #include <errno.h>  #include <errno.h>
 #include "forth.h"  
 #include "io.h"  #include "io.h"
 #include "threaded.h"  #include "threaded.h"
 #ifndef STANDALONE  #ifndef STANDALONE
Line 38 Line 40
 #include <sys/time.h>  #include <sys/time.h>
 #include <unistd.h>  #include <unistd.h>
 #include <pwd.h>  #include <pwd.h>
   #include <dirent.h>
   #include <sys/resource.h>
   #ifdef HAVE_FNMATCH_H
   #include <fnmatch.h>
   #else
   #include "fnmatch.h"
   #endif
 #else  #else
 #include "systypes.h"  #include "systypes.h"
 #endif  #endif
Line 65  struct F83Name { Line 74  struct F83Name {
   char          name[0];    char          name[0];
 };  };
   
 /* are macros for setting necessary? */  
 #define F83NAME_COUNT(np)       ((np)->countetc & 0x1f)  #define F83NAME_COUNT(np)       ((np)->countetc & 0x1f)
 #define F83NAME_SMUDGE(np)      (((np)->countetc & 0x40) != 0)  
 #define F83NAME_IMMEDIATE(np)   (((np)->countetc & 0x20) != 0)  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;  Cell *SP;
 Float *FP;  Float *FP;
Line 80  int emitcounter; Line 94  int emitcounter;
 #endif  #endif
 #define NULLC '\0'  #define NULLC '\0'
   
   #ifdef MEMCMP_AS_SUBROUTINE
   extern int gforth_memcmp(const char * s1, const char * s2, size_t n);
   #define memcmp(s1,s2,n) gforth_memcmp(s1,s2,n)
   #endif
   
 #ifdef HAS_FILE  #ifdef HAS_FILE
 char *cstr(Char *from, UCell size, int clear)  char *cstr(Char *from, UCell size, int clear)
 /* return a C-string corresponding to the Forth string ( FROM SIZE ).  /* return a C-string corresponding to the Forth string ( FROM SIZE ).
Line 132  char *tilde_cstr(Char *from, UCell size, Line 151  char *tilde_cstr(Char *from, UCell size,
     UCell i;      UCell i;
     for (i=1; i<size && from[i]!='/'; i++)      for (i=1; i<size && from[i]!='/'; i++)
       ;        ;
       if (i==2 && from[1]=='+') /* deal with "~+", i.e., the wd */
         return cstr(from+3, size<3?0:size-3,clear);
     {      {
       char user[i];        char user[i];
       memcpy(user,from+1,i-1);        memcpy(user,from+1,i-1);
Line 156  char *tilde_cstr(Char *from, UCell size, Line 177  char *tilde_cstr(Char *from, UCell size,
 }  }
 #endif  #endif
   
   DCell timeval2us(struct timeval *tvp)
   {
   #ifndef BUGGY_LONG_LONG
     return (tvp->tv_sec*(DCell)1000000)+tvp->tv_usec;
   #else
     DCell d2;
     DCell d1=mmul(tvp->tv_sec,1000000);
     d2.lo = d1.lo+tvp->tv_usec;
     d2.hi = d1.hi + (d2.lo<d1.lo);
     return d2;
   #endif
   }
   
 #define NEWLINE '\n'  #define NEWLINE '\n'
   
 #ifndef HAVE_RINT  #ifndef HAVE_RINT
Line 163  char *tilde_cstr(Char *from, UCell size, Line 197  char *tilde_cstr(Char *from, UCell size,
 #endif  #endif
   
 #ifdef HAS_FILE  #ifdef HAS_FILE
 static char* fileattr[6]={"r","rb","r+","r+b","w","wb"};  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  #ifndef O_BINARY
 #define O_BINARY 0  #define O_BINARY 0
Line 173  static char* fileattr[6]={"r","rb","r+", Line 208  static char* fileattr[6]={"r","rb","r+",
 #endif  #endif
   
 static int ufileattr[6]= {  static int ufileattr[6]= {
   O_RDONLY|O_TEXT, O_RDONLY|O_BINARY,    O_RDONLY|O_BINARY, O_RDONLY|O_BINARY,
   O_RDWR  |O_TEXT, O_RDWR  |O_BINARY,    O_RDWR  |O_BINARY, O_RDWR  |O_BINARY,
   O_WRONLY|O_TEXT, O_WRONLY|O_BINARY };    O_WRONLY|O_BINARY, O_WRONLY|O_BINARY };
 #endif  #endif
   
   /* conversion on fetch */
   
   #define vm_Cell2f(x)            ((Bool)(x))
   #define vm_Cell2c(x)            ((Char)(x))
   #define vm_Cell2n(x)            ((Cell)x)
   #define vm_Cell2w(x)            ((Cell)x)
   #define vm_Cell2u(x)            ((UCell)(x))
   #define vm_Cell2a_(x)           ((Cell *)(x))
   #define vm_Cell2c_(x)           ((Char *)(x))
   #define vm_Cell2f_(x)           ((Float *)(x))
   #define vm_Cell2df_(x)          ((DFloat *)(x))
   #define vm_Cell2sf_(x)          ((SFloat *)(x))
   #define vm_Cell2xt(x)           ((Xt)(x))
   #define vm_Cell2f83name(x)      ((struct F83Name *)(x))
   #define vm_Cell2longname(x)     ((struct Longname *)(x))
   #define vm_Float2r(x)   (x)
   
   /* conversion on store */
   
   #define vm_f2Cell(x)            ((Cell)(x))
   #define vm_c2Cell(x)            ((Cell)(x))
   #define vm_n2Cell(x)            ((Cell)(x))
   #define vm_w2Cell(x)            ((Cell)(x))
   #define vm_u2Cell(x)            ((Cell)(x))
   #define vm_a_2Cell(x)           ((Cell)(x))
   #define vm_c_2Cell(x)           ((Cell)(x))
   #define vm_f_2Cell(x)           ((Cell)(x))
   #define vm_df_2Cell(x)          ((Cell)(x))
   #define vm_sf_2Cell(x)          ((Cell)(x))
   #define vm_xt2Cell(x)           ((Cell)(x))
   #define vm_f83name2Cell(x)      ((Cell)(x))
   #define vm_longname2Cell(x)     ((Cell)(x))
   #define vm_r2Float(x)   (x)
   
   #define vm_Cell2Cell(x)         (x)
   
 /* if machine.h has not defined explicit registers, define them as implicit */  /* if machine.h has not defined explicit registers, define them as implicit */
 #ifndef IPREG  #ifndef IPREG
Line 211  static int ufileattr[6]= { Line 282  static int ufileattr[6]= {
 # define CPU_DEP1 0  # define CPU_DEP1 0
 #endif  #endif
   
 /* declare and compute cfa for certain threading variants */  /* instructions containing these must be the last instruction of a
 /* warning: this is nonsyntactical; it will not work in place of a statement */     super-instruction (e.g., branches, EXECUTE, and other instructions
 #ifndef GETCFA     ending the basic block). Instructions containing SET_IP get this
 #define DOCFA     automatically, so you usually don't have to write it.  If you have
      to write it, write it after IP points to the next instruction.
      Used for profiling.  Don't write it in a word containing SET_IP, or
      the following block will be counted twice. */
   #ifdef VM_PROFILING
   #define SUPER_END  vm_count_block(IP)
 #else  #else
 #define DOCFA   Xt cfa; GETCFA(cfa)  #define SUPER_END
 #endif  #endif
   #define SUPER_CONTINUE
   
 #ifdef GFORTH_DEBUGGING  #ifdef GFORTH_DEBUGGING
 /* define some VM registers as global variables, so they survive exceptions;  /* define some VM registers as global variables, so they survive exceptions;
Line 227  Xt *ip; Line 304  Xt *ip;
 Cell *rp;  Cell *rp;
 #endif  #endif
   
 Label *engine(Xt *ip0, Cell *sp0, Cell *rp0, Float *fp0, Address lp0)  #ifdef DEBUG
   #define CFA_TO_NAME(__cfa) \
         Cell len, i; \
         char * name = __cfa; \
         for(i=0; i<32; i+=sizeof(Cell)) { \
           len = ((Cell*)name)[-1]; \
           if(len < 0) { \
             len &= 0x1F; \
             if((len+sizeof(Cell)) > i) break; \
           } len = 0; \
           name -= sizeof(Cell); \
         }
   #endif
   
   Xt *primtable(Label symbols[], Cell size)
        /* used in primitive primtable for peephole optimization */
   {
   #ifdef DIRECT_THREADED
     return symbols;
   #else /* !defined(DIRECT_THREADED) */
     Xt *xts = (Xt *)malloc(size*sizeof(Xt));
     Cell i;
   
     for (i=0; i<size; i++)
       xts[i] = &symbols[i];
     return xts;
   #endif /* !defined(DIRECT_THREADED) */
   }
   
   
   define(enginerest,
   `(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 239  Label *engine(Xt *ip0, Cell *sp0, Cell * Line 347  Label *engine(Xt *ip0, Cell *sp0, Cell *
   register Cell *sp SPREG = sp0;    register Cell *sp SPREG = sp0;
   register Float *fp FPREG = fp0;    register Float *fp FPREG = fp0;
   register Address lp LPREG = lp0;    register Address lp LPREG = lp0;
 #ifdef CFA_NEXT  
   register Xt cfa CFAREG;    register Xt cfa CFAREG;
 #endif  
 #ifdef MORE_VARS  #ifdef MORE_VARS
   MORE_VARS    MORE_VARS
 #endif  #endif
   register Address up UPREG = UP;    register Address up UPREG = UP;
   IF_TOS(register Cell TOS TOSREG;)    IF_spTOS(register Cell spTOS TOSREG;)
   IF_FTOS(register Float FTOS FTOSREG;)    IF_fpTOS(register Float fpTOS FTOSREG;)
 #if defined(DOUBLY_INDIRECT)  #if defined(DOUBLY_INDIRECT)
   static Label *symbols;    static Label *symbols;
   static void *routines[]= {    static void *routines[]= {
   #define MAX_SYMBOLS (sizeof(routines)/sizeof(routines[0]))
 #else /* !defined(DOUBLY_INDIRECT) */  #else /* !defined(DOUBLY_INDIRECT) */
   static Label symbols[]= {    static Label symbols[]= {
   #define MAX_SYMBOLS (sizeof(symbols)/sizeof(symbols[0]))
 #endif /* !defined(DOUBLY_INDIRECT) */  #endif /* !defined(DOUBLY_INDIRECT) */
     (Label)&&docol,      (Label)&&docol,
     (Label)&&docon,      (Label)&&docon,
Line 262  Label *engine(Xt *ip0, Cell *sp0, Cell * Line 370  Label *engine(Xt *ip0, Cell *sp0, Cell *
     (Label)&&dofield,      (Label)&&dofield,
     (Label)&&dodoes,      (Label)&&dodoes,
     /* the following entry is normally unused;      /* the following entry is normally unused;
        it's there because its index indicates a does-handler */         it is there because its index indicates a does-handler */
     CPU_DEP1,      CPU_DEP1,
   #define INST_ADDR(name) (Label)&&I_##name
 #include "prim_lab.i"  #include "prim_lab.i"
     (Label)0  #undef INST_ADDR
       (Label)&&after_last,
       (Label)0,
   #ifdef IN_ENGINE2
   #define INST_ADDR(name) (Label)&&J_##name
   #include "prim_lab.i"
   #undef INST_ADDR
   #endif
   };    };
 #ifdef CPU_DEP2  #ifdef CPU_DEP2
   CPU_DEP2    CPU_DEP2
Line 281  Label *engine(Xt *ip0, Cell *sp0, Cell * Line 397  Label *engine(Xt *ip0, Cell *sp0, Cell *
   
   if (ip == NULL) {    if (ip == NULL) {
 #if defined(DOUBLY_INDIRECT)  #if defined(DOUBLY_INDIRECT)
 #define MAX_SYMBOLS (sizeof(routines)/sizeof(routines[0]))  #define CODE_OFFSET (26*sizeof(Cell))
 #define CODE_OFFSET (22*sizeof(Cell))  #define XT_OFFSET (22*sizeof(Cell))
     int i;      int i;
     Cell code_offset = offset_image? CODE_OFFSET : 0;      Cell code_offset = offset_image? CODE_OFFSET : 0;
       Cell xt_offset = offset_image? XT_OFFSET : 0;
   
     symbols = (Label *)(malloc(MAX_SYMBOLS*sizeof(Cell)+CODE_OFFSET)+code_offset);      symbols = (Label *)(malloc(MAX_SYMBOLS*sizeof(Cell)+CODE_OFFSET)+code_offset);
       xts = (Label *)(malloc(MAX_SYMBOLS*sizeof(Cell)+XT_OFFSET)+xt_offset);
     for (i=0; i<DOESJUMP+1; i++)      for (i=0; i<DOESJUMP+1; 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 %d primitives\n",MAX_SYMBOLS);
         exit(1);          exit(1);
         }
         xts[i] = symbols[i] = &routines[i];
     }      }
     symbols[i] = &routines[i];  
   }  
 #endif /* defined(DOUBLY_INDIRECT) */  #endif /* defined(DOUBLY_INDIRECT) */
   return symbols;      return symbols;
 }    }
   
   IF_TOS(TOS = sp[0]);    IF_spTOS(spTOS = sp[0]);
   IF_FTOS(FTOS = fp[0]);    IF_fpTOS(fpTOS = fp[0]);
 /*  prep_terminal(); */  /*  prep_terminal(); */
   SET_IP(ip);    SET_IP(ip);
     SUPER_END; /* count the first block, too */
   NEXT;    NEXT;
   
   
Line 313  Label *engine(Xt *ip0, Cell *sp0, Cell * Line 432  Label *engine(Xt *ip0, Cell *sp0, Cell *
       
  docol:   docol:
   {    {
     DOCFA;  
 #ifdef DEBUG  #ifdef DEBUG
     fprintf(stderr,"%08lx: col: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));      {
         CFA_TO_NAME(cfa);
         fprintf(stderr,"%08lx: col: %08lx %.*s\n",(Cell)ip,(Cell)PFA1(cfa),
                 len,name);
       }
 #endif  #endif
 #ifdef CISC_NEXT  #ifdef CISC_NEXT
     /* this is the simple version */      /* this is the simple version */
     *--rp = (Cell)ip;      *--rp = (Cell)ip;
     SET_IP((Xt *)PFA1(cfa));      SET_IP((Xt *)PFA1(cfa));
       SUPER_END;
     NEXT;      NEXT;
 #else  #else
     /* this one is important, so we help the compiler optimizing */      /* this one is important, so we help the compiler optimizing */
Line 328  Label *engine(Xt *ip0, Cell *sp0, Cell * Line 451  Label *engine(Xt *ip0, Cell *sp0, Cell *
       DEF_CA        DEF_CA
       rp[-1] = (Cell)ip;        rp[-1] = (Cell)ip;
       SET_IP((Xt *)PFA1(cfa));        SET_IP((Xt *)PFA1(cfa));
         SUPER_END;
       NEXT_P1;        NEXT_P1;
       rp--;        rp--;
       NEXT_P2;        NEXT_P2;
Line 337  Label *engine(Xt *ip0, Cell *sp0, Cell * Line 461  Label *engine(Xt *ip0, Cell *sp0, Cell *
   
  docon:   docon:
   {    {
     DOCFA;  
 #ifdef DEBUG  #ifdef DEBUG
     fprintf(stderr,"%08lx: con: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa));      fprintf(stderr,"%08lx: con: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa));
 #endif  #endif
 #ifdef USE_TOS  #ifdef USE_TOS
     *sp-- = TOS;      *sp-- = spTOS;
     TOS = *(Cell *)PFA1(cfa);      spTOS = *(Cell *)PFA1(cfa);
 #else  #else
     *--sp = *(Cell *)PFA1(cfa);      *--sp = *(Cell *)PFA1(cfa);
 #endif  #endif
Line 353  Label *engine(Xt *ip0, Cell *sp0, Cell * Line 476  Label *engine(Xt *ip0, Cell *sp0, Cell *
       
  dovar:   dovar:
   {    {
     DOCFA;  
 #ifdef DEBUG  #ifdef DEBUG
     fprintf(stderr,"%08lx: var: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));      fprintf(stderr,"%08lx: var: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
 #endif  #endif
 #ifdef USE_TOS  #ifdef USE_TOS
     *sp-- = TOS;      *sp-- = spTOS;
     TOS = (Cell)PFA1(cfa);      spTOS = (Cell)PFA1(cfa);
 #else  #else
     *--sp = (Cell)PFA1(cfa);      *--sp = (Cell)PFA1(cfa);
 #endif  #endif
Line 369  Label *engine(Xt *ip0, Cell *sp0, Cell * Line 491  Label *engine(Xt *ip0, Cell *sp0, Cell *
       
  douser:   douser:
   {    {
     DOCFA;  
 #ifdef DEBUG  #ifdef DEBUG
     fprintf(stderr,"%08lx: user: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));      fprintf(stderr,"%08lx: user: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
 #endif  #endif
 #ifdef USE_TOS  #ifdef USE_TOS
     *sp-- = TOS;      *sp-- = spTOS;
     TOS = (Cell)(up+*(Cell*)PFA1(cfa));      spTOS = (Cell)(up+*(Cell*)PFA1(cfa));
 #else  #else
     *--sp = (Cell)(up+*(Cell*)PFA1(cfa));      *--sp = (Cell)(up+*(Cell*)PFA1(cfa));
 #endif  #endif
Line 385  Label *engine(Xt *ip0, Cell *sp0, Cell * Line 506  Label *engine(Xt *ip0, Cell *sp0, Cell *
       
  dodefer:   dodefer:
   {    {
     DOCFA;  
 #ifdef DEBUG  #ifdef DEBUG
     fprintf(stderr,"%08lx: defer: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa));      fprintf(stderr,"%08lx: defer: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa));
 #endif  #endif
       SUPER_END;
     EXEC(*(Xt *)PFA1(cfa));      EXEC(*(Xt *)PFA1(cfa));
   }    }
   
  dofield:   dofield:
   {    {
     DOCFA;  
 #ifdef DEBUG  #ifdef DEBUG
     fprintf(stderr,"%08lx: field: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));      fprintf(stderr,"%08lx: field: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
 #endif  #endif
     TOS += *(Cell*)PFA1(cfa);      spTOS += *(Cell*)PFA1(cfa);
   }    }
   NEXT_P0;    NEXT_P0;
   NEXT;    NEXT;
Line 422  Label *engine(Xt *ip0, Cell *sp0, Cell * Line 542  Label *engine(Xt *ip0, Cell *sp0, Cell *
             
      */       */
   {    {
     DOCFA;  
   
     /*    fprintf(stderr, "Got CFA %08lx at doescode %08lx/%08lx: does: %08lx\n",cfa,(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa));*/      /*    fprintf(stderr, "Got CFA %08lx at doescode %08lx/%08lx: does: %08lx\n",cfa,(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa));*/
 #ifdef DEBUG  #ifdef DEBUG
     fprintf(stderr,"%08lx/%08lx: does: %08lx\n",(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa));      fprintf(stderr,"%08lx/%08lx: does: %08lx\n",(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa));
Line 432  Label *engine(Xt *ip0, Cell *sp0, Cell * Line 550  Label *engine(Xt *ip0, Cell *sp0, Cell *
     *--rp = (Cell)ip;      *--rp = (Cell)ip;
     /* PFA1 might collide with DOES_CODE1 here, so we use PFA */      /* PFA1 might collide with DOES_CODE1 here, so we use PFA */
 #ifdef USE_TOS  #ifdef USE_TOS
     *sp-- = TOS;      *sp-- = spTOS;
     TOS = (Cell)PFA(cfa);      spTOS = (Cell)PFA(cfa);
 #else  #else
     *--sp = (Cell)PFA(cfa);      *--sp = (Cell)PFA(cfa);
 #endif  #endif
     SET_IP(DOES_CODE1(cfa));      SET_IP(DOES_CODE1(cfa));
     /*    fprintf(stderr,"TOS = %08lx, IP=%08lx\n", TOS, IP);*/      SUPER_END;
       /*    fprintf(stderr,"TOS = %08lx, IP=%08lx\n", spTOS, IP);*/
   }    }
   NEXT;    NEXT;
   
   #ifndef IN_ENGINE2
   #define LABEL(name) I_##name
   #else
   #define LABEL(name) J_##name: asm(".skip 16"); I_##name
   #endif
 #include "prim.i"  #include "prim.i"
 }  #undef LABEL
     after_last: return (Label *)0;
     /*needed only to get the length of the last primitive */
   }'
   )
   
   Label *engine enginerest
   
   #define IN_ENGINE2
   Label *engine2 enginerest
   

Removed from v.1.12  
changed lines
  Added in v.1.39


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