File:  [gforth] / gforth / Attic / engine.c
Revision 1.32: download - view: text, annotated - select for diffs
Sun Dec 10 19:02:07 1995 UTC (25 years, 8 months ago) by anton
Branches: MAIN
CVS tags: gforth-0_1beta, HEAD
cleaned up engine.c a bit (fewer ifdefs)
added direct threading for the Alpha architecture
timings.sc contains some timings (not well organized)

    1: /* Gforth virtual machine (aka inner interpreter)
    2: 
    3:   Copyright (C) 1995 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 <ctype.h>
   23: #include <stdio.h>
   24: #include <string.h>
   25: #include <math.h>
   26: #include <sys/types.h>
   27: #include <sys/stat.h>
   28: #include <fcntl.h>
   29: #include <assert.h>
   30: #include <stdlib.h>
   31: #include <time.h>
   32: #include <sys/time.h>
   33: #include <unistd.h>
   34: #include <errno.h>
   35: #include <pwd.h>
   36: #include "forth.h"
   37: #include "io.h"
   38: #include "threading.h"
   39: 
   40: #ifndef SEEK_SET
   41: /* should be defined in stdio.h, but some systems don't have it */
   42: #define SEEK_SET 0
   43: #endif
   44: 
   45: #define IOR(flag)	((flag)? -512-errno : 0)
   46: 
   47: typedef union {
   48:   struct {
   49: #ifdef WORDS_BIGENDIAN
   50:     Cell high;
   51:     Cell low;
   52: #else
   53:     Cell low;
   54:     Cell high;
   55: #endif;
   56:   } cells;
   57:   DCell dcell;
   58: } Double_Store;
   59: 
   60: typedef struct F83Name {
   61:   struct F83Name	*next;  /* the link field for old hands */
   62:   char			countetc;
   63:   Char			name[0];
   64: } F83Name;
   65: 
   66: /* are macros for setting necessary? */
   67: #define F83NAME_COUNT(np)	((np)->countetc & 0x1f)
   68: #define F83NAME_SMUDGE(np)	(((np)->countetc & 0x40) != 0)
   69: #define F83NAME_IMMEDIATE(np)	(((np)->countetc & 0x20) != 0)
   70: 
   71: #ifdef USE_TOS
   72: #define IF_TOS(x) x
   73: #else
   74: #define IF_TOS(x)
   75: #define TOS (sp[0])
   76: #endif
   77: 
   78: #ifdef USE_FTOS
   79: #define IF_FTOS(x) x
   80: #else
   81: #define IF_FTOS(x)
   82: #define FTOS (fp[0])
   83: #endif
   84: 
   85: Cell *SP;
   86: Float *FP;
   87: int emitcounter;
   88: #define NULLC '\0'
   89: 
   90: char *cstr(Char *from, UCell size, int clear)
   91: /* if clear is true, scratch can be reused, otherwise we want more of
   92:    the same */
   93: {
   94:   static char *scratch=NULL;
   95:   static unsigned scratchsize=0;
   96:   static char *nextscratch;
   97:   char *oldnextscratch;
   98: 
   99:   if (clear)
  100:     nextscratch=scratch;
  101:   if (scratch==NULL) {
  102:     scratch=malloc(size+1);
  103:     nextscratch=scratch;
  104:     scratchsize=size;
  105:   }
  106:   else if (nextscratch+size>scratch+scratchsize) {
  107:     char *oldscratch=scratch;
  108:     scratch = realloc(scratch, (nextscratch-scratch)+size+1);
  109:     nextscratch=scratch+(nextscratch-oldscratch);
  110:     scratchsize=size;
  111:   }
  112:   memcpy(nextscratch,from,size);
  113:   nextscratch[size]='\0';
  114:   oldnextscratch = nextscratch;
  115:   nextscratch += size+1;
  116:   return oldnextscratch;
  117: }
  118: 
  119: char *tilde_cstr(Char *from, UCell size, int clear)
  120: /* like cstr(), but perform tilde expansion on the string */
  121: {
  122:   char *s1,*s2;
  123:   int s1_len, s2_len;
  124:   struct passwd *getpwnam (), *user_entry;
  125: 
  126:   if (size<1 || from[0]!='~')
  127:     return cstr(from, size, clear);
  128:   if (size<2 || from[1]=='/') {
  129:     s1 = (char *)getenv ("HOME");
  130:     s2 = from+1;
  131:     s2_len = size-1;
  132:   } else {
  133:     int i;
  134:     for (i=1; i<size && from[i]!='/'; i++)
  135:       ;
  136:     {
  137:       char user[i];
  138:       memcpy(user,from+1,i-1);
  139:       user[i-1]='\0';
  140:       user_entry=getpwnam(user);
  141:     }
  142:     if (user_entry==NULL)
  143:       return cstr(from, size, clear);
  144:     s1 = user_entry->pw_dir;
  145:     s2 = from+i;
  146:     s2_len = size-i;
  147:   }
  148:   s1_len = strlen(s1);
  149:   if (s1_len>1 && s1[s1_len-1]=='/')
  150:     s1_len--;
  151:   {
  152:     char path[s1_len+s2_len];
  153:     memcpy(path,s1,s1_len);
  154:     memcpy(path+s1_len,s2,s2_len);
  155:     return cstr(path,s1_len+s2_len,clear);
  156:   }
  157: }
  158:    
  159: 
  160: #define NEWLINE	'\n'
  161: 
  162: #ifndef HAVE_RINT
  163: #define rint(x)	floor((x)+0.5)
  164: #endif
  165: 
  166: static char* fileattr[6]={"r","rb","r+","r+b","w","wb"};
  167: 
  168: static Address up0=NULL;
  169: 
  170: /* if machine.h has not defined explicit registers, define them as implicit */
  171: #ifndef IPREG
  172: #define IPREG
  173: #endif
  174: #ifndef SPREG
  175: #define SPREG
  176: #endif
  177: #ifndef RPREG
  178: #define RPREG
  179: #endif
  180: #ifndef FPREG
  181: #define FPREG
  182: #endif
  183: #ifndef LPREG
  184: #define LPREG
  185: #endif
  186: #ifndef CFAREG
  187: #define CFAREG
  188: #endif
  189: #ifndef UPREG
  190: #define UPREG
  191: #endif
  192: #ifndef TOSREG
  193: #define TOSREG
  194: #endif
  195: #ifndef FTOSREG
  196: #define FTOSREG
  197: #endif
  198: 
  199: /* declare and compute cfa for certain threading variants */
  200: /* warning: this is nonsyntactical; it will not work in place of a statement */
  201: #ifdef CFA_NEXT
  202: #define DOCFA
  203: #else
  204: #define DOCFA	Xt cfa; GETCFA(cfa)
  205: #endif
  206: 
  207: Label *engine(Xt *ip0, Cell *sp0, Cell *rp0, Float *fp0, Address lp0)
  208: /* executes code at ip, if ip!=NULL
  209:    returns array of machine code labels (for use in a loader), if ip==NULL
  210: */
  211: {
  212:   register Xt *ip IPREG = ip0;
  213:   register Cell *sp SPREG = sp0;
  214:   register Cell *rp RPREG = rp0;
  215:   register Float *fp FPREG = fp0;
  216:   register Address lp LPREG = lp0;
  217: #ifdef CFA_NEXT
  218:   register Xt cfa CFAREG;
  219: #endif
  220:   register Address up UPREG = up0;
  221:   IF_TOS(register Cell TOS TOSREG;)
  222:   IF_FTOS(register Float FTOS FTOSREG;)
  223:   static Label symbols[]= {
  224:     &&docol,
  225:     &&docon,
  226:     &&dovar,
  227:     &&douser,
  228:     &&dodefer,
  229:     &&dofield,
  230:     &&dodoes,
  231:     /* the following entry is normally unused;
  232:        it's there because its index indicates a does-handler */
  233: #ifdef CPU_DEP1
  234:     CPU_DEP1,
  235: #else
  236:     (Label)0,
  237: #endif
  238: #include "prim_labels.i"
  239:   };
  240: #ifdef CPU_DEP2
  241:   CPU_DEP2
  242: #endif
  243: 
  244: #ifdef DEBUG
  245:   fprintf(stderr,"ip=%x, sp=%x, rp=%x, fp=%x, lp=%x, up=%x\n",
  246:           (unsigned)ip,(unsigned)sp,(unsigned)rp,
  247: 	  (unsigned)fp,(unsigned)lp,(unsigned)up);
  248: #endif
  249: 
  250:   if (ip == NULL)
  251:     return symbols;
  252: 
  253:   IF_TOS(TOS = sp[0]);
  254:   IF_FTOS(FTOS = fp[0]);
  255: /*  prep_terminal(); */
  256:   NEXT_P0;
  257:   NEXT;
  258: 
  259: #ifdef CPU_DEP3
  260:   CPU_DEP3
  261: #endif
  262:   
  263:  docol:
  264:   {
  265:     DOCFA;
  266: #ifdef DEBUG
  267:     fprintf(stderr,"%08lx: col: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
  268: #endif
  269: #ifdef CISC_NEXT
  270:     /* this is the simple version */
  271:     *--rp = (Cell)ip;
  272:     ip = (Xt *)PFA1(cfa);
  273:     NEXT_P0;
  274:     NEXT;
  275: #else
  276:     /* this one is important, so we help the compiler optimizing
  277:        The following version may be better (for scheduling), but probably has
  278:        problems with code fields employing calls and delay slots
  279:        */
  280:     {
  281:       DEF_CA
  282:       Xt *current_ip = (Xt *)PFA1(cfa);
  283:       cfa = *current_ip;
  284:       NEXT1_P1;
  285:       *--rp = (Cell)ip;
  286:       ip = current_ip+1;
  287:       NEXT1_P2;
  288:     }
  289: #endif
  290:   }
  291: 
  292:  docon:
  293:   {
  294:     DOCFA;
  295: #ifdef DEBUG
  296:     fprintf(stderr,"%08lx: con: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa));
  297: #endif
  298: #ifdef USE_TOS
  299:     *sp-- = TOS;
  300:     TOS = *(Cell *)PFA1(cfa);
  301: #else
  302:     *--sp = *(Cell *)PFA1(cfa);
  303: #endif
  304:   }
  305:   NEXT_P0;
  306:   NEXT;
  307:   
  308:  dovar:
  309:   {
  310:     DOCFA;
  311: #ifdef DEBUG
  312:     fprintf(stderr,"%08lx: var: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
  313: #endif
  314: #ifdef USE_TOS
  315:     *sp-- = TOS;
  316:     TOS = (Cell)PFA1(cfa);
  317: #else
  318:     *--sp = (Cell)PFA1(cfa);
  319: #endif
  320:   }
  321:   NEXT_P0;
  322:   NEXT;
  323:   
  324:  douser:
  325:   {
  326:     DOCFA;
  327: #ifdef DEBUG
  328:     fprintf(stderr,"%08lx: user: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
  329: #endif
  330: #ifdef USE_TOS
  331:     *sp-- = TOS;
  332:     TOS = (Cell)(up+*(Cell*)PFA1(cfa));
  333: #else
  334:     *--sp = (Cell)(up+*(Cell*)PFA1(cfa));
  335: #endif
  336:   }
  337:   NEXT_P0;
  338:   NEXT;
  339:   
  340:  dodefer:
  341:   {
  342:     DOCFA;
  343: #ifdef DEBUG
  344:     fprintf(stderr,"%08lx: defer: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa));
  345: #endif
  346:     EXEC(*(Xt *)PFA1(cfa));
  347:   }
  348: 
  349:  dofield:
  350:   {
  351:     DOCFA;
  352: #ifdef DEBUG
  353:     fprintf(stderr,"%08lx: field: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
  354: #endif
  355:     TOS += *(Cell*)PFA1(cfa); 
  356:   }
  357:   NEXT_P0;
  358:   NEXT;
  359: 
  360:  dodoes:
  361:   /* this assumes the following structure:
  362:      defining-word:
  363:      
  364:      ...
  365:      DOES>
  366:      (possible padding)
  367:      possibly handler: jmp dodoes
  368:      (possible branch delay slot(s))
  369:      Forth code after DOES>
  370:      
  371:      defined word:
  372:      
  373:      cfa: address of or jump to handler OR
  374:           address of or jump to dodoes, address of DOES-code
  375:      pfa:
  376:      
  377:      */
  378:   {
  379:     DOCFA;
  380: 
  381:     /*    fprintf(stderr, "Got CFA %08lx at doescode %08lx/%08lx: does: %08lx\n",cfa,(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa));*/
  382: #ifdef DEBUG
  383:     fprintf(stderr,"%08lx/%08lx: does: %08lx\n",(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa));
  384:     fflush(stderr);
  385: #endif
  386:     *--rp = (Cell)ip;
  387:     /* PFA1 might collide with DOES_CODE1 here, so we use PFA */
  388:     ip = DOES_CODE1(cfa);
  389: #ifdef USE_TOS
  390:     *sp-- = TOS;
  391:     TOS = (Cell)PFA(cfa);
  392: #else
  393:     *--sp = (Cell)PFA(cfa);
  394: #endif
  395:     /*    fprintf(stderr,"TOS = %08lx, IP=%08lx\n", TOS, IP);*/
  396:   }
  397:   NEXT_P0;
  398:   NEXT;
  399: 
  400: #include "primitives.i"
  401: }

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