[gforth] / gforth / engine / main.c  

gforth: gforth/engine/main.c

Diff for /gforth/engine/main.c between version 1.54 and 1.97

version 1.54, Tue Jan 15 10:40:04 2002 UTC version 1.97, Sun Jan 26 12:31:45 2003 UTC
Line 21 
Line 21 
 */  */
   
 #include "config.h"  #include "config.h"
   #include "forth.h"
 #include <errno.h>  #include <errno.h>
 #include <ctype.h>  #include <ctype.h>
 #include <stdio.h>  #include <stdio.h>
Line 39 
Line 40 
 #include <sys/mman.h>  #include <sys/mman.h>
 #endif  #endif
 #endif  #endif
 #include "forth.h"  
 #include "io.h"  #include "io.h"
 #include "getopt.h"  #include "getopt.h"
 #ifdef STANDALONE  #ifdef STANDALONE
 #include <systypes.h>  #include <systypes.h>
 #endif  #endif
   
   /* global variables for engine.c
      We put them here because engine.c is compiled several times in
      different ways for the same engine. */
   Cell *SP;
   Float *FP;
   Address UP=NULL;
   
   #ifdef GFORTH_DEBUGGING
   /* define some VM registers as global variables, so they survive exceptions;
      global register variables are not up to the task (according to the
      GNU C manual) */
   Xt *saved_ip;
   Cell *rp;
   #endif
   
   #ifdef NO_IP
   Label next_code;
   #endif
   
   #ifdef HAS_FILE
   char* fileattr[6]={"rb","rb","r+b","r+b","wb","wb"};
   char* pfileattr[6]={"r","r","r+","r+","w","w"};
   
   #ifndef O_BINARY
   #define O_BINARY 0
   #endif
   #ifndef O_TEXT
   #define O_TEXT 0
   #endif
   
   int ufileattr[6]= {
     O_RDONLY|O_BINARY, O_RDONLY|O_BINARY,
     O_RDWR  |O_BINARY, O_RDWR  |O_BINARY,
     O_WRONLY|O_BINARY, O_WRONLY|O_BINARY };
   #endif
   /* end global vars for engine.c */
   
 #define PRIM_VERSION 1  #define PRIM_VERSION 1
 /* increment this whenever the primitives change in an incompatible way */  /* increment this whenever the primitives change in an incompatible way */
   
Line 57 
Line 94 
 jmp_buf throw_jmp_buf;  jmp_buf throw_jmp_buf;
 #endif  #endif
   
 #if defined(DIRECT_THREADED)  #if defined(DOUBLY_INDIRECT)
 /*#  define CA(n) (symbols[(n)])*/  #  define CFA(n)        ({Cell _n = (n); ((Cell)(((_n & 0x4000) ? symbols : xts)+(_n&~0x4000UL)));})
 #  define CA(n) (symbols[(n)&~0x4000UL])  
 #elif defined(DOUBLY_INDIRECT)  
 /* #  define CA(n)      ((Cell)(symbols+((n)&~0x4000UL))) */  
 #  define CA(n) ({Cell _n = (n); ((Cell)(((_n & 0x4000) ? symbols : xts)+(_n&~0x4000UL)));})  
 #else  #else
 #  define CA(n) ((Cell)(symbols+((n)&~0x4000UL)))  #  define CFA(n)        ((Cell)(symbols+((n)&~0x4000UL)))
 #endif  #endif
   
 #define maxaligned(n)   (typeof(n))((((Cell)n)+sizeof(Float)-1)&-sizeof(Float))  #define maxaligned(n)   (typeof(n))((((Cell)n)+sizeof(Float)-1)&-sizeof(Float))
Line 85 
Line 118 
 int optind = 1;  int optind = 1;
 #endif  #endif
   
   #define CODE_BLOCK_SIZE (256*1024)
 Address code_area=0;  Address code_area=0;
 Address code_here=0; /* does for code-area what HERE does for the dictionary */  Cell code_area_size = CODE_BLOCK_SIZE;
   Address code_here=NULL+CODE_BLOCK_SIZE; /* does for code-area what HERE
                                              does for the dictionary */
   Address start_flush=0; /* start of unflushed code */
   Cell last_jump=0; /* if the last prim was compiled without jump, this
                        is it's number, otherwise this contains 0 */
   
   static int no_super=0;   /* true if compile_prim should not fuse prims */
   static int no_dynamic=NO_DYNAMIC_DEFAULT; /* if true, no code is generated
                                                dynamically */
   
 #ifdef HAS_DEBUG  #ifdef HAS_DEBUG
 static int debug=0;  int debug=0;
 #else  #else
 # define debug 0  
 # define perror(x...)  # define perror(x...)
 # define fprintf(x...)  # define fprintf(x...)
 #endif  #endif
Line 112 
Line 154 
 /* image file format:  /* image file format:
  *  "#! binary-path -i\n" (e.g., "#! /usr/local/bin/gforth-0.4.0 -i\n")   *  "#! binary-path -i\n" (e.g., "#! /usr/local/bin/gforth-0.4.0 -i\n")
  *   padding to a multiple of 8   *   padding to a multiple of 8
  *   magic: "Gforth2x" means format 0.4,   *   magic: "Gforth3x" means format 0.6,
  *              where x is a byte with   *              where x is a byte with
  *              bit 7:   reserved = 0   *              bit 7:   reserved = 0
  *              bit 6:5: address unit size 2^n octets   *              bit 6:5: address unit size 2^n octets
Line 136 
Line 178 
  * If the word is <CF(DOESJUMP) and bit 14 is set, it's the xt of a primitive   * If the word is <CF(DOESJUMP) and bit 14 is set, it's the xt of a primitive
  * If the word is <CF(DOESJUMP) and bit 14 is clear,   * If the word is <CF(DOESJUMP) and bit 14 is clear,
  *                                        it's the threaded code of a primitive   *                                        it's the threaded code of a primitive
    * bits 13..9 of a primitive token state which group the primitive belongs to,
    * bits 8..0 of a primitive token index into the group
  */   */
   
   static Cell groups[32] = {
     0,
   #undef GROUP
   #define GROUP(x, n) DOESJUMP+1+n,
   #include "prim_grp.i"
   #undef GROUP
   #define GROUP(x, n)
   };
   
 void relocate(Cell *image, const char *bitstring,  void relocate(Cell *image, const char *bitstring,
               int size, int base, Label symbols[])                int size, Cell base, Label symbols[])
 {  {
   int i=0, j, k, steps=(size/sizeof(Cell))/RELINFOBITS;    int i=0, j, k, steps=(size/sizeof(Cell))/RELINFOBITS;
   Cell token;    Cell token;
   char bits;    char bits;
   Cell max_symbols;    Cell max_symbols;
   /*    /*
    * A virtial start address that's the real start address minus     * A virtual start address that's the real start address minus
    * the one in the image     * the one in the image
    */     */
   Cell *start = (Cell * ) (((void *) image) - ((void *) base));    Cell *start = (Cell * ) (((void *) image) - ((void *) base));
   
     /* group index into table */
   
 /* printf("relocating to %x[%x] start=%x base=%x\n", image, size, start, base); */  /* printf("relocating to %x[%x] start=%x base=%x\n", image, size, start, base); */
   
Line 165 
Line 219 
       if((i < size) && (bits & (1U << (RELINFOBITS-1)))) {        if((i < size) && (bits & (1U << (RELINFOBITS-1)))) {
         /* fprintf(stderr,"relocate: image[%d]=%d of %d\n", i, image[i], size/sizeof(Cell)); */          /* fprintf(stderr,"relocate: image[%d]=%d of %d\n", i, image[i], size/sizeof(Cell)); */
         token=image[i];          token=image[i];
         if(token<0)          if(token<0) {
           switch(token)            int group = (-token & 0x3E00) >> 9;
             {            if(group == 0) {
               switch(token|0x4000) {
             case CF_NIL      : image[i]=0; break;              case CF_NIL      : image[i]=0; break;
 #if !defined(DOUBLY_INDIRECT)  #if !defined(DOUBLY_INDIRECT)
             case CF(DOCOL)   :              case CF(DOCOL)   :
Line 176 
Line 231 
             case CF(DOUSER)  :              case CF(DOUSER)  :
             case CF(DODEFER) :              case CF(DODEFER) :
             case CF(DOFIELD) : MAKE_CF(image+i,symbols[CF(token)]); break;              case CF(DOFIELD) : MAKE_CF(image+i,symbols[CF(token)]); break;
             case CF(DOESJUMP): MAKE_DOES_HANDLER(image+i); break;              case CF(DOESJUMP): image[i]=0; break;
 #endif /* !defined(DOUBLY_INDIRECT) */  #endif /* !defined(DOUBLY_INDIRECT) */
             case CF(DODOES)  :              case CF(DODOES)  :
               MAKE_DOES_CF(image+i,(Xt *)(image[i+1]+((Cell)start)));                MAKE_DOES_CF(image+i,(Xt *)(image[i+1]+((Cell)start)));
               break;                break;
             default          :              default          : /* backward compatibility */
 /*            printf("Code field generation image[%x]:=CA(%x)\n",  /*            printf("Code field generation image[%x]:=CFA(%x)\n",
                      i, CF(image[i])); */                       i, CF(image[i])); */
 #if !defined(DOUBLY_INDIRECT)                if (CF((token | 0x4000))<max_symbols) {
               if (((token | 0x4000) >= CF(DODOES)) && (token < -0x4000))                  image[i]=(Cell)CFA(CF(token));
                 fprintf(stderr,"Doer %d used in this image at $%lx is marked as Xt;\n executing this code will crash.\n",CF((token | 0x4000)),(long)&image[i],VERSION);  #ifdef DIRECT_THREADED
                   if ((token & 0x4000) == 0) /* threade code, no CFA */
                     compile_prim1(&image[i]);
 #endif  #endif
               if (CF((token | 0x4000))<max_symbols)                } else
                 image[i]=(Cell)CA(CF(token));                  fprintf(stderr,"Primitive %d used in this image at $%lx is not implemented by this\n engine (%s); executing this code will crash.\n",CF(token),(long)&image[i],PACKAGE_VERSION);
               else  
                 fprintf(stderr,"Primitive %d used in this image at $%lx is not implemented by this\n engine (%s); executing this code will crash.\n",CF(token),(long)&image[i],VERSION);  
             }              }
         else {            } else {
               int tok = -token & 0x1FF;
               if (tok < (groups[group+1]-groups[group])) {
   #if defined(DOUBLY_INDIRECT)
                 image[i]=(Cell)CFA(((groups[group]+tok) | (CF(token) & 0x4000)));
   #else
                 image[i]=(Cell)CFA((groups[group]+tok));
   #endif
   #ifdef DIRECT_THREADED
                 if ((token & 0x4000) == 0) /* threade code, no CFA */
                   compile_prim1(&image[i]);
   #endif
               } else
                 fprintf(stderr,"Primitive %x, %d of group %d used in this image at $%lx is not implemented by this\n engine (%s); executing this code will crash.\n", -token, tok, group, (long)&image[i],PACKAGE_VERSION);
             }
           } else {
           // if base is > 0: 0 is a null reference so don't adjust            // if base is > 0: 0 is a null reference so don't adjust
           if (token>=base) {            if (token>=base) {
             image[i]+=(Cell)start;              image[i]+=(Cell)start;
Line 202 
Line 272 
       }        }
     }      }
   }    }
     finish_code();
   ((ImageHeader*)(image))->base = (Address) image;    ((ImageHeader*)(image))->base = (Address) image;
 }  }
   
Line 266 
Line 337 
 #ifndef MAP_PRIVATE  #ifndef MAP_PRIVATE
 # define MAP_PRIVATE 0  # define MAP_PRIVATE 0
 #endif  #endif
   #if !defined(MAP_ANON) && defined(MAP_ANONYMOUS)
   # define MAP_ANON MAP_ANONYMOUS
   #endif
   
 #if defined(HAVE_MMAP)  #if defined(HAVE_MMAP)
 static Address alloc_mmap(Cell size)  static Address alloc_mmap(Cell size)
Line 312 
Line 386 
   return verbose_malloc(size);    return verbose_malloc(size);
 }  }
   
 #if (defined(mips) && !defined(INDIRECT_THREADED))  
 /* the 256MB jump restriction on the MIPS architecture makes the  
    combination of direct threading and mmap unsafe. */  
 #define mips_dict_alloc 1  
 #define dict_alloc(size) verbose_malloc(size)  
 #else  
 #define dict_alloc(size) my_alloc(size)  
 #endif  
   
 Address dict_alloc_read(FILE *file, Cell imagesize, Cell dictsize, Cell offset)  Address dict_alloc_read(FILE *file, Cell imagesize, Cell dictsize, Cell offset)
 {  {
   Address image = MAP_FAILED;    Address image = MAP_FAILED;
   
 #if defined(HAVE_MMAP) && !defined(mips_dict_alloc)  #if defined(HAVE_MMAP)
   if (offset==0) {    if (offset==0) {
     image=alloc_mmap(dictsize);      image=alloc_mmap(dictsize);
     if (debug)      if (debug)
Line 333 
Line 398 
     image = mmap(image, imagesize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_FIXED|MAP_FILE|MAP_PRIVATE, fileno(file), 0);      image = mmap(image, imagesize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_FIXED|MAP_FILE|MAP_PRIVATE, fileno(file), 0);
     after_alloc(image,dictsize);      after_alloc(image,dictsize);
   }    }
 #endif /* defined(MAP_ANON) && !defined(mips_dict_alloc) */  #endif /* defined(HAVE_MMAP) */
   if (image == MAP_FAILED) {    if (image == MAP_FAILED) {
     image = dict_alloc(dictsize+offset)+offset;      image = my_alloc(dictsize+offset)+offset;
     rewind(file);  /* fseek(imagefile,0L,SEEK_SET); */      rewind(file);  /* fseek(imagefile,0L,SEEK_SET); */
     fread(image, 1, imagesize, file);      fread(image, 1, imagesize, file);
   }    }
Line 373 
Line 438 
   header->fp_stack_base=my_alloc(fsize);    header->fp_stack_base=my_alloc(fsize);
   header->return_stack_base=my_alloc(rsize);    header->return_stack_base=my_alloc(rsize);
   header->locals_stack_base=my_alloc(lsize);    header->locals_stack_base=my_alloc(lsize);
   code_here = code_area = my_alloc(dictsize);  
 }  }
   
 #warning You can ignore the warnings about clobbered variables in go_forth  #warning You can ignore the warnings about clobbered variables in go_forth
Line 412 
Line 476 
     signal_data_stack[7]=throw_code;      signal_data_stack[7]=throw_code;
   
 #ifdef GFORTH_DEBUGGING  #ifdef GFORTH_DEBUGGING
     /* fprintf(stderr,"\nrp=%ld\n",(long)rp); */      if (debug)
         fprintf(stderr,"\ncaught signal, throwing exception %d, ip=%p rp=%p\n",
                 throw_code, saved_ip, rp);
     if (rp <= orig_rp0 && rp > (Cell *)(image_header->return_stack_base+5)) {      if (rp <= orig_rp0 && rp > (Cell *)(image_header->return_stack_base+5)) {
       /* no rstack overflow or underflow */        /* no rstack overflow or underflow */
       rp0 = rp;        rp0 = rp;
       *--rp0 = (Cell)ip;        *--rp0 = (Cell)saved_ip;
     }      }
     else /* I love non-syntactic ifdefs :-) */      else /* I love non-syntactic ifdefs :-) */
 #endif  
     rp0 = signal_return_stack+8;      rp0 = signal_return_stack+8;
   #else  /* !defined(GFORTH_DEBUGGING) */
       if (debug)
         fprintf(stderr,"\ncaught signal, throwing exception %d\n", throw_code);
         rp0 = signal_return_stack+8;
   #endif /* !defined(GFORTH_DEBUGGING) */
     /* fprintf(stderr, "rp=$%x\n",rp0);*/      /* fprintf(stderr, "rp=$%x\n",rp0);*/
   
     return((int)(Cell)engine(image_header->throw_entry, signal_data_stack+7,      return((int)(Cell)engine(image_header->throw_entry, signal_data_stack+7,
Line 431 
Line 501 
   return((int)(Cell)engine(ip0,sp0,rp0,fp0,lp0));    return((int)(Cell)engine(ip0,sp0,rp0,fp0,lp0));
 }  }
   
   
 #ifndef INCLUDE_IMAGE  #ifndef INCLUDE_IMAGE
 void print_sizes(Cell sizebyte)  void print_sizes(Cell sizebyte)
      /* print size information */       /* print size information */
Line 445 
Line 514 
           1 << ((sizebyte >> 5) & 3));            1 << ((sizebyte >> 5) & 3));
 }  }
   
   #define MAX_IMMARGS 2
   
   #ifndef NO_DYNAMIC
 typedef struct {  typedef struct {
   Label start;    Label start;
   Cell length; /* excluding the jump */    Cell length; /* only includes the jump iff superend is true*/
   char super_end; /* true if primitive ends superinstruction, i.e.,    Cell restlength; /* length of the rest (i.e., the jump or (on superend) 0) */
     char superend; /* true if primitive ends superinstruction, i.e.,
                      unconditional branch, execute, etc. */                       unconditional branch, execute, etc. */
     Cell nimmargs;
     struct immarg {
       Cell offset; /* offset of immarg within prim */
       char rel;    /* true if immarg is relative */
     } immargs[MAX_IMMARGS];
 } PrimInfo;  } PrimInfo;
   
 PrimInfo *priminfos;  PrimInfo *priminfos;
   PrimInfo **decomp_prims;
   
   int compare_priminfo_length(const void *_a, const void *_b)
   {
     PrimInfo **a = (PrimInfo **)_a;
     PrimInfo **b = (PrimInfo **)_b;
     Cell diff = (*a)->length - (*b)->length;
     if (diff)
       return diff;
     else /* break ties by start address; thus the decompiler produces
             the earliest primitive with the same code (e.g. noop instead
             of (char) and @ instead of >code-address */
       return (*b)->start - (*a)->start;
   }
   
   #endif /* defined(NO_DYNAMIC) */
 Cell npriminfos=0;  Cell npriminfos=0;
   
   
 void check_prims(Label symbols1[])  void check_prims(Label symbols1[])
 {  {
 #if defined(IS_NEXT_JUMP) && !defined(DOUBLY_INDIRECT)  
   int i;    int i;
   Label *symbols2=engine2(0,0,0,0,0);  #ifndef NO_DYNAMIC
     Label *symbols2, *symbols3, *ends1;
   static char superend[]={    static char superend[]={
 #include "prim_superend.i"  #include "prim_superend.i"
   };    };
   #endif
   
     if (debug)
   #ifdef __VERSION__
       fprintf(stderr, "Compiled with gcc-" __VERSION__ "\n");
   #else
   #define xstr(s) str(s)
   #define str(s) #s
     fprintf(stderr, "Compiled with gcc-" xstr(__GNUC__) "." xstr(__GNUC_MINOR__) "\n");
   #endif
   for (i=DOESJUMP+1; symbols1[i+1]!=0; i++)    for (i=DOESJUMP+1; symbols1[i+1]!=0; i++)
     ;      ;
   priminfos = calloc(i,sizeof(PrimInfo));  
   npriminfos = i;    npriminfos = i;
   
   #ifndef NO_DYNAMIC
     if (no_dynamic)
       return;
     symbols2=engine2(0,0,0,0,0);
   #if NO_IP
     symbols3=engine3(0,0,0,0,0);
   #else
     symbols3=symbols1;
   #endif
     ends1 = symbols1+i+1-DOESJUMP;
     priminfos = calloc(i,sizeof(PrimInfo));
   for (i=DOESJUMP+1; symbols1[i+1]!=0; i++) {    for (i=DOESJUMP+1; symbols1[i+1]!=0; i++) {
     int prim_len=symbols1[i+1]-symbols1[i];      int prim_len = ends1[i]-symbols1[i];
     PrimInfo *pi=&priminfos[i];      PrimInfo *pi=&priminfos[i];
     int j;      int j=0;
     pi->super_end = superend[i-DOESJUMP-1];      char *s1 = (char *)symbols1[i];
     for (j=prim_len-IND_JUMP_LENGTH; ; j--) {      char *s2 = (char *)symbols2[i];
       if (IS_NEXT_JUMP(symbols1[i]+j)) {      char *s3 = (char *)symbols3[i];
         prim_len = j;  
         if (pi->super_end)      pi->start = s1;
           prim_len += IND_JUMP_LENGTH; /* include the jump */      pi->superend = superend[i-DOESJUMP-1]|no_super;
       if (pi->superend)
         pi->length = symbols1[i+1]-symbols1[i];
       else
         pi->length = prim_len;
       pi->restlength = symbols1[i+1] - symbols1[i] - pi->length;
       pi->nimmargs = 0;
       if (debug)
         fprintf(stderr, "Prim %3d @ %p %p %p, length=%3d restlength=%2d superend=%1d",
                 i, s1, s2, s3, pi->length, pi->restlength, pi->superend);
       assert(prim_len>=0);
       while (j<(pi->length+pi->restlength)) {
         if (s1[j]==s3[j]) {
           if (s1[j] != s2[j]) {
             pi->start = NULL; /* not relocatable */
             if (debug)
               fprintf(stderr,"\n   non_reloc: engine1!=engine2 offset %3d",j);
             /* assert(j<prim_len); */
         break;          break;
       }        }
       if (j==0) { /* NEXT jump not found, e.g., execute */          j++;
         if (!pi->super_end && debug)        } else {
           fprintf(stderr, "NEXT jump not found for primitive %d, making it super_end\n", i);          struct immarg *ia=&pi->immargs[pi->nimmargs];
         pi->super_end = 1;  
           pi->nimmargs++;
           ia->offset=j;
           if ((~*(Cell *)&(s1[j]))==*(Cell *)&(s3[j])) {
             ia->rel=0;
             if (debug)
               fprintf(stderr,"\n   absolute immarg: offset %3d",j);
           } else if ((&(s1[j]))+(*(Cell *)&(s1[j]))+4 ==
                      symbols1[DOESJUMP+1]) {
             ia->rel=1;
             if (debug)
               fprintf(stderr,"\n   relative immarg: offset %3d",j);
           } else {
             pi->start = NULL; /* not relocatable */
             if (debug)
               fprintf(stderr,"\n   non_reloc: engine1!=engine3 offset %3d",j);
             /* assert(j<prim_len);*/
         break;          break;
       }        }
           j+=4;
         }
     }      }
     /* fprintf(stderr,"checking primitive %d: memcmp(%p, %p, %d)\n",  
        i, symbols1[i], symbols2[i], prim_len);*/  
     if (memcmp(symbols1[i],symbols2[i],prim_len)!=0) {  
       if (debug)  
         fprintf(stderr,"Primitive %d not relocatable: memcmp(%p, %p, %d)\n",  
                 i, symbols1[i], symbols2[i], prim_len);  
     } else {  
       pi->start = symbols1[i];  
       pi->length = prim_len;  
       if (debug)        if (debug)
         fprintf(stderr,"Primitive %d relocatable: start %p, length %ld, super_end %d\n",        fprintf(stderr,"\n");
                 i, pi->start, pi->length, pi->super_end);  
     }      }
     decomp_prims = calloc(i,sizeof(PrimInfo *));
     for (i=DOESJUMP+1; i<npriminfos; i++)
       decomp_prims[i] = &(priminfos[i]);
     qsort(decomp_prims+DOESJUMP+1, npriminfos-DOESJUMP-1, sizeof(PrimInfo *),
           compare_priminfo_length);
   #endif
   }    }
   
   void flush_to_here(void)
   {
   #ifndef NO_DYNAMIC
     FLUSH_ICACHE(start_flush, code_here-start_flush);
     start_flush=code_here;
 #endif  #endif
 }  }
   
 Label compile_prim(Label prim)  #ifndef NO_DYNAMIC
   void append_jump(void)
 {  {
 #ifdef DOUBLY_INDIRECT    if (last_jump) {
   if (prim<((Label)(xts+DOESJUMP)) || prim>((Label)(xts+npriminfos))) {      PrimInfo *pi = &priminfos[last_jump];
     fprintf(stderr,"compile_prim encountered xt %p\n", prim);  
     return prim;      memcpy(code_here, pi->start+pi->length, pi->restlength);
   } else      code_here += pi->restlength;
     return prim-((Label)xts)+((Label)vm_prims);      last_jump=0;
 #else /* !defined(DOUBLY_INDIRECT) */    }
 #ifdef IND_JUMP_LENGTH  }
   int i;  
   /* Gforth remembers all code blocks in this list.  On forgetting (by
   executing a marker) the code blocks are not freed (because Gforth does
   not remember how they were allocated; hmm, remembering that might be
   easier and cleaner).  Instead, code_here etc. are reset to the old
   value, and the "forgotten" code blocks are reused when they are
   needed. */
   
   struct code_block_list {
     struct code_block_list *next;
     Address block;
     Cell size;
   } *code_block_list=NULL, **next_code_blockp=&code_block_list;
   
   Address append_prim(Cell p)
   {
     PrimInfo *pi = &priminfos[p];
   Address old_code_here=code_here;    Address old_code_here=code_here;
   static Address last_jump=0;  
   
   for (i=0; ; i++) {    if (code_area+code_area_size < code_here+pi->length+pi->restlength) {
     if (i>=npriminfos) { /* not a relocatable prim */      struct code_block_list *p;
       if (last_jump) { /* make sure the last sequence is complete */      append_jump();
         memcpy(code_here, last_jump, IND_JUMP_LENGTH);      flush_to_here();
         code_here += IND_JUMP_LENGTH;      if (*next_code_blockp == NULL) {
         code_here = start_flush = code_area = my_alloc(code_area_size);
         p = (struct code_block_list *)malloc(sizeof(struct code_block_list));
         *next_code_blockp = p;
         p->next = NULL;
         p->block = code_here;
         p->size = code_area_size;
       } else {
         p = *next_code_blockp;
         code_here = start_flush = code_area = p->block;
       }
       old_code_here = code_here;
       next_code_blockp = &(p->next);
     }
     memcpy(code_here, pi->start, pi->length);
     code_here += pi->length;
     return old_code_here;
   }
   #endif
   
   int forget_dyncode(Address code)
   {
   #ifdef NO_DYNAMIC
     return -1;
   #else
     struct code_block_list *p, **pp;
   
     for (pp=&code_block_list, p=*pp; p!=NULL; pp=&(p->next), p=*pp) {
       if (code >= p->block && code < p->block+p->size) {
         next_code_blockp = &(p->next);
         code_here = start_flush = code;
         code_area = p->block;
         last_jump = 0;          last_jump = 0;
         return -1;
       }        }
       return prim;  
     }      }
     if (priminfos[i].start==prim)    return -no_dynamic;
   #endif /* !defined(NO_DYNAMIC) */
   }
   
   Label decompile_code(Label _code)
   {
   #ifdef NO_DYNAMIC
     return _code;
   #else /* !defined(NO_DYNAMIC) */
     Cell i;
     struct code_block_list *p;
     Address code=_code;
   
     /* first, check if we are in code at all */
     for (p = code_block_list;; p = p->next) {
       if (p == NULL)
         return code;
       if (code >= p->block && code < p->block+p->size)
       break;        break;
   }    }
     /* reverse order because NOOP might match other prims */
     for (i=npriminfos-1; i>DOESJUMP; i--) {
       PrimInfo *pi=decomp_prims[i];
       if (pi->start==code || (pi->start && memcmp(code,pi->start,pi->length)==0))
         return pi->start;
     }
     return code;
   #endif /* !defined(NO_DYNAMIC) */
   }
   
   #ifdef NO_IP
   int nbranchinfos=0;
   
   struct branchinfo {
     Label *targetptr; /* *(bi->targetptr) is the target */
     Cell *addressptr; /* store the target here */
   } branchinfos[100000];
   
   int ndoesexecinfos=0;
   struct doesexecinfo {
     int branchinfo; /* fix the targetptr of branchinfos[...->branchinfo] */
     Cell *xt; /* cfa of word whose does-code needs calling */
   } doesexecinfos[10000];
   
   /* definitions of N_execute etc. */
   #include "prim_num.i"
   
   void set_rel_target(Cell *source, Label target)
   {
     *source = ((Cell)target)-(((Cell)source)+4);
   }
   
   void register_branchinfo(Label source, Cell targetptr)
   {
     struct branchinfo *bi = &(branchinfos[nbranchinfos]);
     bi->targetptr = (Label *)targetptr;
     bi->addressptr = (Cell *)source;
     nbranchinfos++;
   }
   
   Cell *compile_prim1arg(Cell p)
   {
     int l = priminfos[p].length;
     Address old_code_here=code_here;
   
     assert(vm_prims[p]==priminfos[p].start);
     append_prim(p);
     return (Cell*)(old_code_here+priminfos[p].immargs[0].offset);
   }
   
   Cell *compile_call2(Cell targetptr)
   {
     Cell *next_code_target;
     PrimInfo *pi = &priminfos[N_call2];
     Address old_code_here = append_prim(N_call2);
   
     next_code_target = (Cell *)(old_code_here + pi->immargs[0].offset);
     register_branchinfo(old_code_here + pi->immargs[1].offset, targetptr);
     return next_code_target;
   }
   #endif
   
   void finish_code(void)
   {
   #ifdef NO_IP
     Cell i;
   
     compile_prim1(NULL);
     for (i=0; i<ndoesexecinfos; i++) {
       struct doesexecinfo *dei = &doesexecinfos[i];
       branchinfos[dei->branchinfo].targetptr = DOES_CODE1((dei->xt));
     }
     ndoesexecinfos = 0;
     for (i=0; i<nbranchinfos; i++) {
       struct branchinfo *bi=&branchinfos[i];
       set_rel_target(bi->addressptr, *(bi->targetptr));
     }
     nbranchinfos = 0;
   #endif
     flush_to_here();
   }
   
   void compile_prim1(Cell *start)
   {
   #if defined(DOUBLY_INDIRECT)
     Label prim=(Label)*start;
     if (prim<((Label)(xts+DOESJUMP)) || prim>((Label)(xts+npriminfos))) {
       fprintf(stderr,"compile_prim encountered xt %p\n", prim);
       *start=(Cell)prim;
       return;
     } else {
       *start = (Cell)(prim-((Label)xts)+((Label)vm_prims));
       return;
     }
   #elif defined(NO_IP)
     static Cell *last_start=NULL;
     static Xt last_prim=NULL;
     /* delay work by one call in order to get relocated immargs */
   
     if (last_start) {
       unsigned i = last_prim-vm_prims;
       PrimInfo *pi=&priminfos[i];
       Cell *next_code_target=NULL;
   
       assert(i<npriminfos);
       if (i==N_execute||i==N_perform||i==N_lit_perform) {
         next_code_target = compile_prim1arg(N_set_next_code);
       }
       if (i==N_call) {
         next_code_target = compile_call2(last_start[1]);
       } else if (i==N_does_exec) {
         struct doesexecinfo *dei = &doesexecinfos[ndoesexecinfos++];
         *compile_prim1arg(N_lit) = (Cell)PFA(last_start[1]);
         /* we cannot determine the callee now (last_start[1] may be a
            forward reference), so just register an arbitrary target, and
            register in dei that we need to fix this before resolving
            branches */
         dei->branchinfo = nbranchinfos;
         dei->xt = (Cell *)(last_start[1]);
         next_code_target = compile_call2(NULL);
       } else if (pi->start == NULL) { /* non-reloc */
         next_code_target = compile_prim1arg(N_set_next_code);
         set_rel_target(compile_prim1arg(N_abranch),*(Xt)last_prim);
       } else {
         unsigned j;
         Address old_code_here = append_prim(i);
   
         for (j=0; j<pi->nimmargs; j++) {
           struct immarg *ia = &(pi->immargs[j]);
           Cell argval = last_start[pi->nimmargs - j]; /* !! specific to prims */
           if (ia->rel) { /* !! assumption: relative refs are branches */
             register_branchinfo(old_code_here + ia->offset, argval);
           } else /* plain argument */
             *(Cell *)(old_code_here + ia->offset) = argval;
         }
       }
       if (next_code_target!=NULL)
         *next_code_target = (Cell)code_here;
     }
     if (start) {
       last_prim = (Xt)*start;
       *start = (Cell)code_here;
     }
     last_start = start;
     return;
   #elif !defined(NO_DYNAMIC)
     Label prim=(Label)*start;
     unsigned i;
     Address old_code_here;
   
     i = ((Xt)prim)-vm_prims;
     prim = *(Xt)prim;
     if (no_dynamic) {
       *start = (Cell)prim;
       return;
     }
     if (i>=npriminfos || priminfos[i].start == 0) { /* not a relocatable prim */
       append_jump();
       *start = (Cell)prim;
       return;
     }
     assert(priminfos[i].start = prim);
 #ifdef ALIGN_CODE  #ifdef ALIGN_CODE
   ALIGN_CODE;    /*  ALIGN_CODE;*/
 #endif  #endif
   memcpy(code_here, (Address)prim, priminfos[i].length);    assert(prim==priminfos[i].start);
   code_here += priminfos[i].length;    old_code_here = append_prim(i);
   last_jump = (priminfos[i].super_end) ? 0 : (prim+priminfos[i].length);    last_jump = (priminfos[i].superend) ? 0 : i;
   return (Label)old_code_here;    *start = (Cell)old_code_here;
 #else    return;
   return prim;  #else /* !defined(DOUBLY_INDIRECT), no code replication */
     Label prim=(Label)*start;
   #if !defined(INDIRECT_THREADED)
     prim = *(Xt)prim;
 #endif  #endif
     *start = (Cell)prim;
     return;
 #endif /* !defined(DOUBLY_INDIRECT) */  #endif /* !defined(DOUBLY_INDIRECT) */
 }  }
   
   Label compile_prim(Label prim)
   {
     Cell x=(Cell)prim;
     assert(0);
     compile_prim1(&x);
     return (Label)x;
   }
   
   #if defined(PRINT_SUPER_LENGTHS) && !defined(NO_DYNAMIC)
   Cell prim_length(Cell prim)
   {
     return priminfos[prim+DOESJUMP+1].length;
   }
   #endif
   
 Address loader(FILE *imagefile, char* filename)  Address loader(FILE *imagefile, char* filename)
 /* returns the address of the image proper (after the preamble) */  /* returns the address of the image proper (after the preamble) */
 {  {
Line 574 
Line 972 
   vm_prims = engine(0,0,0,0,0);    vm_prims = engine(0,0,0,0,0);
   check_prims(vm_prims);    check_prims(vm_prims);
 #ifndef DOUBLY_INDIRECT  #ifndef DOUBLY_INDIRECT
   #ifdef PRINT_SUPER_LENGTHS
     print_super_lengths();
   #endif
   check_sum = checksum(vm_prims);    check_sum = checksum(vm_prims);
 #else /* defined(DOUBLY_INDIRECT) */  #else /* defined(DOUBLY_INDIRECT) */
   check_sum = (UCell)vm_prims;    check_sum = (UCell)vm_prims;
Line 581 
Line 982 
   
   do {    do {
     if(fread(magic,sizeof(Char),8,imagefile) < 8) {      if(fread(magic,sizeof(Char),8,imagefile) < 8) {
       fprintf(stderr,"%s: image %s doesn't seem to be a Gforth (>=0.4) image.\n",        fprintf(stderr,"%s: image %s doesn't seem to be a Gforth (>=0.6) image.\n",
               progname, filename);                progname, filename);
       exit(1);        exit(1);
     }      }
     preamblesize+=8;      preamblesize+=8;
   } while(memcmp(magic,"Gforth2",7));    } while(memcmp(magic,"Gforth3",7));
   magic7 = magic[7];    magic7 = magic[7];
   if (debug) {    if (debug) {
     magic[7]='\0';      magic[7]='\0';
Line 620 
Line 1021 
   image = dict_alloc_read(imagefile, preamblesize+header.image_size,    image = dict_alloc_read(imagefile, preamblesize+header.image_size,
                           preamblesize+dictsize, data_offset);                            preamblesize+dictsize, data_offset);
   imp=image+preamblesize;    imp=image+preamblesize;
     alloc_stacks((ImageHeader *)imp);
   if (clear_dictionary)    if (clear_dictionary)
     memset(imp+header.image_size, 0, dictsize-header.image_size);      memset(imp+header.image_size, 0, dictsize-header.image_size);
   if(header.base==0 || header.base  == 0x100) {    if(header.base==0 || header.base  == (Address)0x100) {
     Cell reloc_size=((header.image_size-1)/sizeof(Cell))/8+1;      Cell reloc_size=((header.image_size-1)/sizeof(Cell))/8+1;
     char reloc_bits[reloc_size];      char reloc_bits[reloc_size];
     fseek(imagefile, preamblesize+header.image_size, SEEK_SET);      fseek(imagefile, preamblesize+header.image_size, SEEK_SET);
     fread(reloc_bits, 1, reloc_size, imagefile);      fread(reloc_bits, 1, reloc_size, imagefile);
     relocate((Cell *)imp, reloc_bits, header.image_size, header.base, vm_prims);      relocate((Cell *)imp, reloc_bits, header.image_size, (Cell)header.base, vm_prims);
 #if 0  #if 0
     { /* let's see what the relocator did */      { /* let's see what the relocator did */
       FILE *snapshot=fopen("snapshot.fi","wb");        FILE *snapshot=fopen("snapshot.fi","wb");
Line 653 
Line 1055 
 #endif  #endif
   fclose(imagefile);    fclose(imagefile);
   
   alloc_stacks((ImageHeader *)imp);    /* unnecessary, except maybe for CODE words */
     /* FLUSH_ICACHE(imp, header.image_size);*/
   CACHE_FLUSH(imp, header.image_size);  
   
   return imp;    return imp;
 }  }
   
 /* index of last '/' or '\' in file, 0 if there is none. !! Hmm, could  /* pointer to last '/' or '\' in file, 0 if there is none. */
    be implemented with strrchr and the separator should be  char *onlypath(char *filename)
    OS-dependent */  
 int onlypath(char *file)  
 {  {
   int i;    return strrchr(filename, DIRSEP);
   i=strlen(file);  
   while (i) {  
     if (file[i]=='\\' || file[i]=='/') break;  
     i--;  
   }  
   return i;  
 }  }
   
 FILE *openimage(char *fullfilename)  FILE *openimage(char *fullfilename)
Line 692 
Line 1085 
   char fullfilename[dirlen+strlen(imagename)+2];    char fullfilename[dirlen+strlen(imagename)+2];
   
   memcpy(fullfilename, path, dirlen);    memcpy(fullfilename, path, dirlen);
   if (fullfilename[dirlen-1]!='/')    if (fullfilename[dirlen-1]!=DIRSEP)
     fullfilename[dirlen++]='/';      fullfilename[dirlen++]=DIRSEP;
   strcpy(fullfilename+dirlen,imagename);    strcpy(fullfilename+dirlen,imagename);
   return openimage(fullfilename);    return openimage(fullfilename);
 }  }
Line 703 
Line 1096 
   FILE * image_file=NULL;    FILE * image_file=NULL;
   char *origpath=path;    char *origpath=path;
   
   if(strchr(imagename, '/')==NULL) {    if(strchr(imagename, DIRSEP)==NULL) {
     /* first check the directory where the exe file is in !! 01may97jaw */      /* first check the directory where the exe file is in !! 01may97jaw */
     if (onlypath(progname))      if (onlypath(progname))
       image_file=checkimage(progname, onlypath(progname), imagename);        image_file=checkimage(progname, onlypath(progname)-progname, imagename);
     if (!image_file)      if (!image_file)
       do {        do {
         char *pend=strchr(path, PATHSEP);          char *pend=strchr(path, PATHSEP);
Line 789 
Line 1182 
       {"clear-dictionary", no_argument, &clear_dictionary, 1},        {"clear-dictionary", no_argument, &clear_dictionary, 1},
       {"die-on-signal", no_argument, &die_on_signal, 1},        {"die-on-signal", no_argument, &die_on_signal, 1},
       {"debug", no_argument, &debug, 1},        {"debug", no_argument, &debug, 1},
         {"no-super", no_argument, &no_super, 1},
         {"no-dynamic", no_argument, &no_dynamic, 1},
         {"dynamic", no_argument, &no_dynamic, 0},
       {0,0,0,0}        {0,0,0,0}
       /* no-init-file, no-rc? */        /* no-init-file, no-rc? */
     };      };
Line 811 
Line 1207 
     case 'c': clear_dictionary = 1; break;      case 'c': clear_dictionary = 1; break;
     case 's': die_on_signal = 1; break;      case 's': die_on_signal = 1; break;
     case 'x': debug = 1; break;      case 'x': debug = 1; break;
     case 'v': fprintf(stderr, "gforth %s\n", VERSION); exit(0);      case 'v': fputs(PACKAGE_STRING"\n", stderr); exit(0);
     case 'h':      case 'h':
       fprintf(stderr, "Usage: %s [engine options] ['--'] [image arguments]\n\        fprintf(stderr, "Usage: %s [engine options] ['--'] [image arguments]\n\
 Engine Options:\n\  Engine Options:\n\
Line 820 
Line 1216 
   -d SIZE, --data-stack-size=SIZE   Specify data stack size\n\    -d SIZE, --data-stack-size=SIZE   Specify data stack size\n\
   --debug                           Print debugging information during startup\n\    --debug                           Print debugging information during startup\n\
   --die-on-signal                   exit instead of CATCHing some signals\n\    --die-on-signal                   exit instead of CATCHing some signals\n\
     --dynamic                         use dynamic native code\n\
   -f SIZE, --fp-stack-size=SIZE     Specify floating point stack size\n\    -f SIZE, --fp-stack-size=SIZE     Specify floating point stack size\n\
   -h, --help                        Print this message and exit\n\    -h, --help                        Print this message and exit\n\
   -i FILE, --image-file=FILE        Use image FILE instead of `gforth.fi'\n\    -i FILE, --image-file=FILE        Use image FILE instead of `gforth.fi'\n\
   -l SIZE, --locals-stack-size=SIZE Specify locals stack size\n\    -l SIZE, --locals-stack-size=SIZE Specify locals stack size\n\
   -m SIZE, --dictionary-size=SIZE   Specify Forth dictionary size\n\    -m SIZE, --dictionary-size=SIZE   Specify Forth dictionary size\n\
     --no-dynamic                      Use only statically compiled primitives\n\
   --no-offset-im                    Load image at normal position\n\    --no-offset-im                    Load image at normal position\n\
     --no-super                        No dynamically formed superinstructions\n\
   --offset-image                    Load image at a different position\n\    --offset-image                    Load image at a different position\n\
   -p PATH, --path=PATH              Search path for finding image and sources\n\    -p PATH, --path=PATH              Search path for finding image and sources\n\
   -r SIZE, --return-stack-size=SIZE Specify return stack size\n\    -r SIZE, --return-stack-size=SIZE Specify return stack size\n\
   -v, --version                     Print version and exit\n\    -v, --version                     Print engine version and exit\n\
 SIZE arguments consist of an integer followed by a unit. The unit can be\n\  SIZE arguments consist of an integer followed by a unit. The unit can be\n\
   `b' (byte), `e' (element; default), `k' (KB), `M' (MB), `G' (GB) or `T' (TB).\n",    `b' (byte), `e' (element; default), `k' (KB), `M' (MB), `G' (GB) or `T' (TB).\n",
               argv[0]);                argv[0]);
Line 859 
Line 1258 
 #endif  #endif
   int retvalue;    int retvalue;
   
 #if defined(i386) && defined(ALIGNMENT_CHECK) && !defined(DIRECT_THREADED)  #if defined(i386) && defined(ALIGNMENT_CHECK)
   /* turn on alignment checks on the 486.    /* turn on alignment checks on the 486.
    * on the 386 this should have no effect. */     * on the 386 this should have no effect. */
   __asm__("pushfl; popl %eax; orl $0x40000, %eax; pushl %eax; popfl;");    __asm__("pushfl; popl %eax; orl $0x40000, %eax; pushl %eax; popfl;");

Generate output suitable for use with a patch program
Legend:
Removed from v.1.54  
changed lines
  Added in v.1.97
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help