Annotation of gforth/engine.c, revision 1.25

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

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