Return to engine.c CVS log

Up to [gforth] / gforth

added code.fs (code, ;code, end-code, assembler)
renamed dostruc to dofield
made index and doc-entries nicer
Only words containing 'e' or 'E' are converted to FP numbers.
added many wordset comments
added flush-icache primitive and FLUSH_ICACHE macro
added +DO, U+DO, -DO, U-DO and -LOOP
added code address labels (`docol:' etc.)
fixed sparc cache_flush

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