[gforth] / gforth / engine / main.c  

gforth: gforth/engine/main.c

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

version 1.43, Wed Feb 28 22:31:43 2001 UTC version 1.54, Tue Jan 15 10:40:04 2002 UTC
Line 58 
Line 58 
 #endif  #endif
   
 #if defined(DIRECT_THREADED)  #if defined(DIRECT_THREADED)
 #  define CA(n) (symbols[(n)])  /*#  define CA(n) (symbols[(n)])*/
   #  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)))  #  define CA(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 81 
Line 85 
 int optind = 1;  int optind = 1;
 #endif  #endif
   
   Address code_area=0;
   Address code_here=0; /* does for code-area what HERE does for the dictionary */
   
 #ifdef HAS_DEBUG  #ifdef HAS_DEBUG
 static int debug=0;  static int debug=0;
 #else  #else
Line 91 
Line 98 
   
 ImageHeader *gforth_header;  ImageHeader *gforth_header;
 Label *vm_prims;  Label *vm_prims;
   #ifdef DOUBLY_INDIRECT
   Label *xts; /* same content as vm_prims, but should only be used for xts */
   #endif
   
 #ifdef MEMCMP_AS_SUBROUTINE  #ifdef MEMCMP_AS_SUBROUTINE
 int gforth_memcmp(const char * s1, const char * s2, size_t n)  int gforth_memcmp(const char * s1, const char * s2, size_t n)
Line 123 
Line 133 
  * If the word =CF(DODOES), it's a DOES> CFA   * If the word =CF(DODOES), it's a DOES> CFA
  * If the word =CF(DOESJUMP), it's a DOES JUMP (2 Cells after DOES>,   * If the word =CF(DOESJUMP), it's a DOES JUMP (2 Cells after DOES>,
  *                                      possibly containing a jump to dodoes)   *                                      possibly containing a jump to dodoes)
  * If the word is <CF(DOESJUMP), it's 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,
    *                                        it's the threaded code of a primitive
  */   */
   
 void relocate(Cell *image, const char *bitstring, int size, Label symbols[])  void relocate(Cell *image, const char *bitstring,
                 int size, int 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
      * the one in the image
      */
     Cell *start = (Cell * ) (((void *) image) - ((void *) base));
   
   
 /*  printf("relocating %x[%x]\n", image, size); */  /* printf("relocating to %x[%x] start=%x base=%x\n", image, size, start, base); */
   
   for (max_symbols=DOESJUMP+1; symbols[max_symbols]!=0; max_symbols++)    for (max_symbols=DOESJUMP+1; symbols[max_symbols]!=0; max_symbols++)
     ;      ;
     max_symbols--;
   size/=sizeof(Cell);    size/=sizeof(Cell);
   
   for(k=0; k<=steps; k++) {    for(k=0; k<=steps; k++) {
Line 144 
Line 164 
       /*      fprintf(stderr,"relocate: image[%d]\n", i);*/        /*      fprintf(stderr,"relocate: image[%d]\n", i);*/
       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)); */
         if((token=image[i])<0)          token=image[i];
           if(token<0)
           switch(token)            switch(token)
             {              {
             case CF_NIL      : image[i]=0; break;              case CF_NIL      : image[i]=0; break;
Line 158 
Line 179 
             case CF(DOESJUMP): MAKE_DOES_HANDLER(image+i); break;              case CF(DOESJUMP): MAKE_DOES_HANDLER(image+i); 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)image)));                MAKE_DOES_CF(image+i,(Xt *)(image[i+1]+((Cell)start)));
               break;                break;
             default          :              default          :
 /*            printf("Code field generation image[%x]:=CA(%x)\n",  /*            printf("Code field generation image[%x]:=CA(%x)\n",
                      i, CF(image[i])); */                       i, CF(image[i])); */
               if (CF(token)<max_symbols)  #if !defined(DOUBLY_INDIRECT)
                 if (((token | 0x4000) >= CF(DODOES)) && (token < -0x4000))
                   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);
   #endif
                 if (CF((token | 0x4000))<max_symbols)
                 image[i]=(Cell)CA(CF(token));                  image[i]=(Cell)CA(CF(token));
               else                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);                  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 {
           image[i]+=(Cell)image;            // if base is > 0: 0 is a null reference so don't adjust
             if (token>=base) {
               image[i]+=(Cell)start;
             }
           }
       }        }
     }      }
   }    }
Line 344 
Line 373 
   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
 int go_forth(Address image, int stack, Cell *entries)  int go_forth(Address image, int stack, Cell *entries)
 {  {
   volatile ImageHeader *image_header = (ImageHeader *)image;    volatile ImageHeader *image_header = (ImageHeader *)image;
   Cell *sp0=(Cell*)(image_header->data_stack_base + dsize);    Cell *sp0=(Cell*)(image_header->data_stack_base + dsize);
   Float *fp0=(Float *)(image_header->fp_stack_base + fsize);  
   Cell *rp0=(Cell *)(image_header->return_stack_base + rsize);    Cell *rp0=(Cell *)(image_header->return_stack_base + rsize);
     Float *fp0=(Float *)(image_header->fp_stack_base + fsize);
   #ifdef GFORTH_DEBUGGING
   volatile Cell *orig_rp0=rp0;    volatile Cell *orig_rp0=rp0;
   #endif
   Address lp0=image_header->locals_stack_base + lsize;    Address lp0=image_header->locals_stack_base + lsize;
   Xt *ip0=(Xt *)(image_header->boot_entry);    Xt *ip0=(Xt *)(image_header->boot_entry);
 #ifdef SYSSIGNALS  #ifdef SYSSIGNALS
Line 412 
Line 445 
           1 << ((sizebyte >> 5) & 3));            1 << ((sizebyte >> 5) & 3));
 }  }
   
   typedef struct {
     Label start;
     Cell length; /* excluding the jump */
     char super_end; /* true if primitive ends superinstruction, i.e.,
                        unconditional branch, execute, etc. */
   } PrimInfo;
   
   PrimInfo *priminfos;
   Cell npriminfos=0;
   
   void check_prims(Label symbols1[])
   {
   #if defined(IS_NEXT_JUMP) && !defined(DOUBLY_INDIRECT)
     int i;
     Label *symbols2=engine2(0,0,0,0,0);
     static char superend[]={
   #include "prim_superend.i"
     };
   
     for (i=DOESJUMP+1; symbols1[i+1]!=0; i++)
       ;
     priminfos = calloc(i,sizeof(PrimInfo));
     npriminfos = i;
     for (i=DOESJUMP+1; symbols1[i+1]!=0; i++) {
       int prim_len=symbols1[i+1]-symbols1[i];
       PrimInfo *pi=&priminfos[i];
       int j;
       pi->super_end = superend[i-DOESJUMP-1];
       for (j=prim_len-IND_JUMP_LENGTH; ; j--) {
         if (IS_NEXT_JUMP(symbols1[i]+j)) {
           prim_len = j;
           if (pi->super_end)
             prim_len += IND_JUMP_LENGTH; /* include the jump */
           break;
         }
         if (j==0) { /* NEXT jump not found, e.g., execute */
           if (!pi->super_end && debug)
             fprintf(stderr, "NEXT jump not found for primitive %d, making it super_end\n", i);
           pi->super_end = 1;
           break;
         }
       }
       /* 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)
           fprintf(stderr,"Primitive %d relocatable: start %p, length %ld, super_end %d\n",
                   i, pi->start, pi->length, pi->super_end);
       }
     }
   #endif
   }
   
   Label compile_prim(Label prim)
   {
   #ifdef DOUBLY_INDIRECT
     if (prim<((Label)(xts+DOESJUMP)) || prim>((Label)(xts+npriminfos))) {
       fprintf(stderr,"compile_prim encountered xt %p\n", prim);
       return prim;
     } else
       return prim-((Label)xts)+((Label)vm_prims);
   #else /* !defined(DOUBLY_INDIRECT) */
   #ifdef IND_JUMP_LENGTH
     int i;
     Address old_code_here=code_here;
     static Address last_jump=0;
   
     for (i=0; ; i++) {
       if (i>=npriminfos) { /* not a relocatable prim */
         if (last_jump) { /* make sure the last sequence is complete */
           memcpy(code_here, last_jump, IND_JUMP_LENGTH);
           code_here += IND_JUMP_LENGTH;
           last_jump = 0;
         }
         return prim;
       }
       if (priminfos[i].start==prim)
         break;
     }
   #ifdef ALIGN_CODE
     ALIGN_CODE;
   #endif
     memcpy(code_here, (Address)prim, priminfos[i].length);
     code_here += priminfos[i].length;
     last_jump = (priminfos[i].super_end) ? 0 : (prim+priminfos[i].length);
     return (Label)old_code_here;
   #else
     return prim;
   #endif
   #endif /* !defined(DOUBLY_INDIRECT) */
   }
   
 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 441 
Line 572 
     ;      ;
   
   vm_prims = engine(0,0,0,0,0);    vm_prims = engine(0,0,0,0,0);
     check_prims(vm_prims);
 #ifndef DOUBLY_INDIRECT  #ifndef DOUBLY_INDIRECT
   check_sum = checksum(vm_prims);    check_sum = checksum(vm_prims);
 #else /* defined(DOUBLY_INDIRECT) */  #else /* defined(DOUBLY_INDIRECT) */
Line 490 
Line 622 
   imp=image+preamblesize;    imp=image+preamblesize;
   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) {    if(header.base==0 || header.base  == 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, vm_prims);      relocate((Cell *)imp, reloc_bits, header.image_size, 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 516 
Line 648 
             progname, (unsigned long)(header.checksum),(unsigned long)check_sum);              progname, (unsigned long)(header.checksum),(unsigned long)check_sum);
     exit(1);      exit(1);
   }    }
   #ifdef DOUBLY_INDIRECT
     ((ImageHeader *)imp)->xt_base = xts;
   #endif
   fclose(imagefile);    fclose(imagefile);
   
   alloc_stacks((ImageHeader *)imp);    alloc_stacks((ImageHeader *)imp);

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help