Return to engine.c CVS log

Up to [gforth] / gforth / engine

there is now a debugging version of the engine that maintains ip and
rp in global variables (to allow backtrace on signals). The debugging
engine is called gforth and the original engine is called gforth-fast.

    1: /* Gforth virtual machine (aka inner interpreter)
    2: 
    3:   Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
    4: 
    5:   This file is part of Gforth.
    6: 
    7:   Gforth is free software; you can redistribute it and/or
    8:   modify it under the terms of the GNU General Public License
    9:   as published by the Free Software Foundation; either version 2
   10:   of the License, or (at your option) any later version.
   11: 
   12:   This program is distributed in the hope that it will be useful,
   13:   but WITHOUT ANY WARRANTY; without even the implied warranty of
   14:   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   15:   GNU General Public License for more details.
   16: 
   17:   You should have received a copy of the GNU General Public License
   18:   along with this program; if not, write to the Free Software
   19:   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   20: */
   21: 
   22: #include "config.h"
   23: #include <ctype.h>
   24: #include <stdio.h>
   25: #include <string.h>
   26: #include <math.h>
   27: #include <assert.h>
   28: #include <stdlib.h>
   29: #include <errno.h>
   30: #include "forth.h"
   31: #include "io.h"
   32: #include "threaded.h"
   33: #ifndef STANDALONE
   34: #include <sys/types.h>
   35: #include <sys/stat.h>
   36: #include <fcntl.h>
   37: #include <time.h>
   38: #include <sys/time.h>
   39: #include <unistd.h>
   40: #include <pwd.h>
   41: #else
   42: #include "systypes.h"
   43: #endif
   44: 
   45: #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) /* what else? */
   46: #include <dlfcn.h>
   47: #endif
   48: #if defined(_WIN32)
   49: #include <windows.h>
   50: #endif
   51: #ifdef hpux
   52: #include <dl.h>
   53: #endif
   54: 
   55: #ifndef SEEK_SET
   56: /* should be defined in stdio.h, but some systems don't have it */
   57: #define SEEK_SET 0
   58: #endif
   59: 
   60: #define IOR(flag)	((flag)? -512-errno : 0)
   61: 
   62: struct F83Name {
   63:   struct F83Name *next;  /* the link field for old hands */
   64:   char		countetc;
   65:   char		name[0];
   66: };
   67: 
   68: /* are macros for setting necessary? */
   69: #define F83NAME_COUNT(np)	((np)->countetc & 0x1f)
   70: #define F83NAME_SMUDGE(np)	(((np)->countetc & 0x40) != 0)
   71: #define F83NAME_IMMEDIATE(np)	(((np)->countetc & 0x20) != 0)
   72: 
   73: Cell *SP;
   74: Float *FP;
   75: Address UP=NULL;
   76: 
   77: #if 0
   78: /* not used currently */
   79: int emitcounter;
   80: #endif
   81: #define NULLC '\0'
   82: 
   83: #ifdef HAS_FILE
   84: char *cstr(Char *from, UCell size, int clear)
   85: /* return a C-string corresponding to the Forth string ( FROM SIZE ).
   86:    the C-string lives until the next call of cstr with CLEAR being true */
   87: {
   88:   static struct cstr_buffer {
   89:     char *buffer;
   90:     size_t size;
   91:   } *buffers=NULL;
   92:   static int nbuffers=0;
   93:   static int used=0;
   94:   struct cstr_buffer *b;
   95: 
   96:   if (buffers==NULL)
   97:     buffers=malloc(0);
   98:   if (clear)
   99:     used=0;
  100:   if (used>=nbuffers) {
  101:     buffers=realloc(buffers,sizeof(struct cstr_buffer)*(used+1));
  102:     buffers[used]=(struct cstr_buffer){malloc(0),0};
  103:     nbuffers=used+1;
  104:   }
  105:   b=&buffers[used];
  106:   if (size+1 > b->size) {
  107:     b->buffer = realloc(b->buffer,size+1);
  108:     b->size = size+1;
  109:   }
  110:   memcpy(b->buffer,from,size);
  111:   b->buffer[size]='\0';
  112:   used++;
  113:   return b->buffer;
  114: }
  115: 
  116: char *tilde_cstr(Char *from, UCell size, int clear)
  117: /* like cstr(), but perform tilde expansion on the string */
  118: {
  119:   char *s1,*s2;
  120:   int s1_len, s2_len;
  121:   struct passwd *getpwnam (), *user_entry;
  122: 
  123:   if (size<1 || from[0]!='~')
  124:     return cstr(from, size, clear);
  125:   if (size<2 || from[1]=='/') {
  126:     s1 = (char *)getenv ("HOME");
  127:     if(s1 == NULL)
  128:       s1 = "";
  129:     s2 = from+1;
  130:     s2_len = size-1;
  131:   } else {
  132:     UCell i;
  133:     for (i=1; i<size && from[i]!='/'; i++)
  134:       ;
  135:     {
  136:       char user[i];
  137:       memcpy(user,from+1,i-1);
  138:       user[i-1]='\0';
  139:       user_entry=getpwnam(user);
  140:     }
  141:     if (user_entry==NULL)
  142:       return cstr(from, size, clear);
  143:     s1 = user_entry->pw_dir;
  144:     s2 = from+i;
  145:     s2_len = size-i;
  146:   }
  147:   s1_len = strlen(s1);
  148:   if (s1_len>1 && s1[s1_len-1]=='/')
  149:     s1_len--;
  150:   {
  151:     char path[s1_len+s2_len];
  152:     memcpy(path,s1,s1_len);
  153:     memcpy(path+s1_len,s2,s2_len);
  154:     return cstr(path,s1_len+s2_len,clear);
  155:   }
  156: }
  157: #endif
  158: 
  159: #define NEWLINE	'\n'
  160: 
  161: #ifndef HAVE_RINT
  162: #define rint(x)	floor((x)+0.5)
  163: #endif
  164: 
  165: #ifdef HAS_FILE
  166: static char* fileattr[6]={"r","rb","r+","r+b","w","wb"};
  167: 
  168: #ifndef O_BINARY
  169: #define O_BINARY 0
  170: #endif
  171: #ifndef O_TEXT
  172: #define O_TEXT 0
  173: #endif
  174: 
  175: static int ufileattr[6]= {
  176:   O_RDONLY|O_TEXT, O_RDONLY|O_BINARY,
  177:   O_RDWR  |O_TEXT, O_RDWR  |O_BINARY,
  178:   O_WRONLY|O_TEXT, O_WRONLY|O_BINARY };
  179: #endif
  180: 
  181: /* if machine.h has not defined explicit registers, define them as implicit */
  182: #ifndef IPREG
  183: #define IPREG
  184: #endif
  185: #ifndef SPREG
  186: #define SPREG
  187: #endif
  188: #ifndef RPREG
  189: #define RPREG
  190: #endif
  191: #ifndef FPREG
  192: #define FPREG
  193: #endif
  194: #ifndef LPREG
  195: #define LPREG
  196: #endif
  197: #ifndef CFAREG
  198: #define CFAREG
  199: #endif
  200: #ifndef UPREG
  201: #define UPREG
  202: #endif
  203: #ifndef TOSREG
  204: #define TOSREG
  205: #endif
  206: #ifndef FTOSREG
  207: #define FTOSREG
  208: #endif
  209: 
  210: #ifndef CPU_DEP1
  211: # define CPU_DEP1 0
  212: #endif
  213: 
  214: /* declare and compute cfa for certain threading variants */
  215: /* warning: this is nonsyntactical; it will not work in place of a statement */
  216: #ifdef CFA_NEXT
  217: #define DOCFA
  218: #else
  219: #define DOCFA	Xt cfa; GETCFA(cfa)
  220: #endif
  221: 
  222: #ifdef GFORTH_DEBUGGING
  223: /* define some VM registers as global variables, so they survive exceptions;
  224:    global register variables are not up to the task (according to the 
  225:    GNU C manual) */
  226: Xt *ip;
  227: Cell *rp;
  228: #endif
  229: 
  230: Label *engine(Xt *ip0, Cell *sp0, Cell *rp0, Float *fp0, Address lp0)
  231: /* executes code at ip, if ip!=NULL
  232:    returns array of machine code labels (for use in a loader), if ip==NULL
  233: */
  234: {
  235: #ifndef GFORTH_DEBUGGING
  236:   register Xt *ip IPREG;
  237:   register Cell *rp RPREG;
  238: #endif
  239:   register Cell *sp SPREG = sp0;
  240:   register Float *fp FPREG = fp0;
  241:   register Address lp LPREG = lp0;
  242: #ifdef CFA_NEXT
  243:   register Xt cfa CFAREG;
  244: #endif
  245:   register Address up UPREG = UP;
  246:   IF_TOS(register Cell TOS TOSREG;)
  247:   IF_FTOS(register Float FTOS FTOSREG;)
  248: #if defined(DOUBLY_INDIRECT)
  249:   static Label *symbols;
  250:   static void *routines[]= {
  251: #else /* !defined(DOUBLY_INDIRECT) */
  252:   static Label symbols[]= {
  253: #endif /* !defined(DOUBLY_INDIRECT) */
  254:     (Label)&&docol,
  255:     (Label)&&docon,
  256:     (Label)&&dovar,
  257:     (Label)&&douser,
  258:     (Label)&&dodefer,
  259:     (Label)&&dofield,
  260:     (Label)&&dodoes,
  261:     /* the following entry is normally unused;
  262:        it's there because its index indicates a does-handler */
  263:     CPU_DEP1,
  264: #include "prim_lab.i"
  265:     (Label)0
  266:   };
  267: #ifdef CPU_DEP2
  268:   CPU_DEP2
  269: #endif
  270: 
  271:   ip = ip0;
  272:   rp = rp0;
  273: #ifdef DEBUG
  274:   fprintf(stderr,"ip=%x, sp=%x, rp=%x, fp=%x, lp=%x, up=%x\n",
  275:           (unsigned)ip,(unsigned)sp,(unsigned)rp,
  276: 	  (unsigned)fp,(unsigned)lp,(unsigned)up);
  277: #endif
  278: 
  279:   if (ip == NULL) {
  280: #if defined(DOUBLY_INDIRECT)
  281: #define MAX_SYMBOLS (sizeof(routines)/sizeof(routines[0]))
  282: #define CODE_OFFSET (22*sizeof(Cell))
  283:     int i;
  284:     Cell code_offset = offset_image? CODE_OFFSET : 0;
  285: 
  286:     symbols = (Label *)(malloc(MAX_SYMBOLS*sizeof(Cell)+CODE_OFFSET)+code_offset);
  287:     for (i=0; i<DOESJUMP+1; i++)
  288:       symbols[i] = (Label)routines[i];
  289:     for (; routines[i]!=0; i++) {
  290:       if (i>=MAX_SYMBOLS) {
  291: 	fprintf(stderr,"gforth-ditc: more than %d primitives\n",MAX_SYMBOLS);
  292: 	exit(1);
  293:     }
  294:     symbols[i] = &routines[i];
  295:   }
  296: #endif /* defined(DOUBLY_INDIRECT) */
  297:   return symbols;
  298: }
  299: 
  300:   IF_TOS(TOS = sp[0]);
  301:   IF_FTOS(FTOS = fp[0]);
  302: /*  prep_terminal(); */
  303:   NEXT_P0;
  304:   NEXT;
  305: 
  306: #ifdef CPU_DEP3
  307:   CPU_DEP3
  308: #endif
  309:   
  310:  docol:
  311:   {
  312:     DOCFA;
  313: #ifdef DEBUG
  314:     fprintf(stderr,"%08lx: col: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
  315: #endif
  316: #ifdef CISC_NEXT
  317:     /* this is the simple version */
  318:     *--rp = (Cell)ip;
  319:     ip = (Xt *)PFA1(cfa);
  320:     NEXT_P0;
  321:     NEXT;
  322: #else
  323:     /* this one is important, so we help the compiler optimizing
  324:        The following version may be better (for scheduling), but probably has
  325:        problems with code fields employing calls and delay slots
  326:        */
  327:     {
  328:       DEF_CA
  329:       Xt *current_ip = (Xt *)PFA1(cfa);
  330:       cfa = *current_ip;
  331:       NEXT1_P1;
  332:       *--rp = (Cell)ip;
  333:       ip = current_ip+1;
  334:       NEXT1_P2;
  335:     }
  336: #endif
  337:   }
  338: 
  339:  docon:
  340:   {
  341:     DOCFA;
  342: #ifdef DEBUG
  343:     fprintf(stderr,"%08lx: con: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa));
  344: #endif
  345: #ifdef USE_TOS
  346:     *sp-- = TOS;
  347:     TOS = *(Cell *)PFA1(cfa);
  348: #else
  349:     *--sp = *(Cell *)PFA1(cfa);
  350: #endif
  351:   }
  352:   NEXT_P0;
  353:   NEXT;
  354:   
  355:  dovar:
  356:   {
  357:     DOCFA;
  358: #ifdef DEBUG
  359:     fprintf(stderr,"%08lx: var: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
  360: #endif
  361: #ifdef USE_TOS
  362:     *sp-- = TOS;
  363:     TOS = (Cell)PFA1(cfa);
  364: #else
  365:     *--sp = (Cell)PFA1(cfa);
  366: #endif
  367:   }
  368:   NEXT_P0;
  369:   NEXT;
  370:   
  371:  douser:
  372:   {
  373:     DOCFA;
  374: #ifdef DEBUG
  375:     fprintf(stderr,"%08lx: user: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
  376: #endif
  377: #ifdef USE_TOS
  378:     *sp-- = TOS;
  379:     TOS = (Cell)(up+*(Cell*)PFA1(cfa));
  380: #else
  381:     *--sp = (Cell)(up+*(Cell*)PFA1(cfa));
  382: #endif
  383:   }
  384:   NEXT_P0;
  385:   NEXT;
  386:   
  387:  dodefer:
  388:   {
  389:     DOCFA;
  390: #ifdef DEBUG
  391:     fprintf(stderr,"%08lx: defer: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa));
  392: #endif
  393:     EXEC(*(Xt *)PFA1(cfa));
  394:   }
  395: 
  396:  dofield:
  397:   {
  398:     DOCFA;
  399: #ifdef DEBUG
  400:     fprintf(stderr,"%08lx: field: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
  401: #endif
  402:     TOS += *(Cell*)PFA1(cfa); 
  403:   }
  404:   NEXT_P0;
  405:   NEXT;
  406: 
  407:  dodoes:
  408:   /* this assumes the following structure:
  409:      defining-word:
  410:      
  411:      ...
  412:      DOES>
  413:      (possible padding)
  414:      possibly handler: jmp dodoes
  415:      (possible branch delay slot(s))
  416:      Forth code after DOES>
  417:      
  418:      defined word:
  419:      
  420:      cfa: address of or jump to handler OR
  421:           address of or jump to dodoes, address of DOES-code
  422:      pfa:
  423:      
  424:      */
  425:   {
  426:     DOCFA;
  427: 
  428:     /*    fprintf(stderr, "Got CFA %08lx at doescode %08lx/%08lx: does: %08lx\n",cfa,(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa));*/
  429: #ifdef DEBUG
  430:     fprintf(stderr,"%08lx/%08lx: does: %08lx\n",(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa));
  431:     fflush(stderr);
  432: #endif
  433:     *--rp = (Cell)ip;
  434:     /* PFA1 might collide with DOES_CODE1 here, so we use PFA */
  435:     ip = DOES_CODE1(cfa);
  436: #ifdef USE_TOS
  437:     *sp-- = TOS;
  438:     TOS = (Cell)PFA(cfa);
  439: #else
  440:     *--sp = (Cell)PFA(cfa);
  441: #endif
  442:     /*    fprintf(stderr,"TOS = %08lx, IP=%08lx\n", TOS, IP);*/
  443:   }
  444:   NEXT_P0;
  445:   NEXT;
  446: 
  447: #include "prim.i"
  448: }