[gforth] / gforth / engine / main.c  

gforth: gforth/engine/main.c

Diff for /gforth/engine/main.c between version 1.50 and 1.77

version 1.50, Sat Dec 29 20:40:49 2001 UTC version 1.77, Fri Dec 13 21:59:39 2002 UTC
Line 57 
Line 57 
 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)));})
 #else  #else
 #  define CA(n) ((Cell)(symbols+(n)))  #  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 81 
Line 81 
 int optind = 1;  int optind = 1;
 #endif  #endif
   
   #define CODE_BLOCK_SIZE (64*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 */
   /* --no-dynamic by default on gcc versions >=3.1 (it works with 3.0.4,
      but not with 3.2) */
   #if (__GNUC__>2 && __GNUC_MINOR__>=1)
   static int no_dynamic=1; /* true if compile_prim should not generate code */
   #else
   static int no_dynamic=0; /* true if compile_prim should not generate code */
   #endif
   
 #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
   
 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 126 
Line 143 
  * 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,  void relocate(Cell *image, const char *bitstring,
Line 157 
Line 176 
         /* 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)            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)
Line 173 
Line 192 
               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          :
 /*            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 (CF(token)<max_symbols)                if (CF((token | 0x4000))<max_symbols) {
                 image[i]=(Cell)CA(CF(token));                  image[i]=(Cell)CFA(CF(token));
               else  #ifdef DIRECT_THREADED
                   if ((token & 0x4000) == 0) /* threade code, no CFA */
                     compile_prim1(&image[i]);
   #endif
                 } 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 {
Line 189 
Line 212 
       }        }
     }      }
   }    }
     finish_code();
   ((ImageHeader*)(image))->base = (Address) image;    ((ImageHeader*)(image))->base = (Address) image;
 }  }
   
Line 299 
Line 323 
   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 320 
Line 335 
     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 360 
Line 375 
   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 403 
Line 417 
     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  #endif
Line 418 
Line 432 
   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 432 
Line 445 
           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(PrimInfo **a, 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);    Label *symbols2, *symbols3, *ends1;
   static char superend[]={    static char superend[]={
 #include "prim_superend.i"  #include "prim_superend.i"
   };    };
   
     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;
         break;      if (pi->superend)
       }        pi->length = symbols1[i+1]-symbols1[i];
       if (j==0) { /* NEXT jump not found, e.g., execute */      else
         if (!pi->super_end && debug)        pi->length = prim_len;
           fprintf(stderr, "NEXT jump not found for primitive %d, making it super_end\n", i);      pi->restlength = symbols1[i+1] - symbols1[i] - pi->length;
         pi->super_end = 1;      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;
       }        }
     }          j++;
     /* fprintf(stderr,"checking primitive %d: memcmp(%p, %p, %d)\n",        } else {
        i, symbols1[i], symbols2[i], prim_len);*/          struct immarg *ia=&pi->immargs[pi->nimmargs];
     if (memcmp(symbols1[i],symbols2[i],prim_len)!=0) {  
           pi->nimmargs++;
           ia->offset=j;
           if ((~*(Cell *)&(s1[j]))==*(Cell *)&(s3[j])) {
             ia->rel=0;
       if (debug)        if (debug)
         fprintf(stderr,"Primitive %d not relocatable: memcmp(%p, %p, %d)\n",              fprintf(stderr,"\n   absolute immarg: offset %3d",j);
                 i, symbols1[i], symbols2[i], prim_len);          } 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 {      } else {
       pi->start = symbols1[i];            pi->start = NULL; /* not relocatable */
       pi->length = prim_len;  
       if (debug)        if (debug)
         fprintf(stderr,"Primitive %d relocatable: start %p, length %ld, super_end %d\n",              fprintf(stderr,"\n   non_reloc: engine1!=engine3 offset %3d",j);
                 i, pi->start, pi->length, pi->super_end);            /* assert(j<prim_len);*/
             break;
     }      }
           j+=4;
   }    }
       }
       if (debug)
         fprintf(stderr,"\n");
     }
     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  #endif
 }  }
   
 Label compile_prim(Label prim)  #ifndef NO_DYNAMIC
   void flush_to_here(void)
 {  {
 #ifdef IND_JUMP_LENGTH    FLUSH_ICACHE(start_flush, code_here-start_flush);
   int i;    start_flush=code_here;
   }
   
   void append_jump(void)
   {
     if (last_jump) {
       PrimInfo *pi = &priminfos[last_jump];
   
       memcpy(code_here, pi->start+pi->length, pi->restlength);
       code_here += pi->restlength;
       last_jump=0;
       flush_to_here();
     }
   }
   
   /* 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);      if (*next_code_blockp == NULL) {
         code_here += IND_JUMP_LENGTH;        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;
     if (pi->superend)
       flush_to_here();
     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;    return 0;
   #endif /* !defined(NO_DYNAMIC) */
     }      }
     if (priminfos[i].start==prim)  
   Label decompile_code(Label code)
   {
   #ifdef NO_DYNAMIC
     return code;
   #else /* !defined(NO_DYNAMIC) */
     Cell i;
     struct code_block_list *p;
   
     /* 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;
     FLUSH_ICACHE(start_flush, code_here-start_flush);
     start_flush=code_here;
   #endif
   }
   
   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 = 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) */
   }
   
   Label compile_prim(Label prim)
   {
     Cell x=(Cell)prim;
     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 553 
Line 898 
   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 599 
Line 947 
   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  == 0x100) {
Line 627 
Line 976 
             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);    /* 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 668 
Line 1011 
   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 679 
Line 1022 
   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 765 
Line 1108 
       {"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 796 
Line 1142 
   -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 821 
Line 1170 
 extern const char reloc_bits[];  extern const char reloc_bits[];
 #endif  #endif
   
   DCell double2ll(Float r)
   {
   #ifndef BUGGY_LONG_LONG
     return (DCell)(r);
   #else
     DCell d;
     d.hi = ldexp(r,-(int)(CELL_BITS)) - (r<0);
     d.lo = r-ldexp((Float)d.hi,CELL_BITS);
     return d;
   #endif
   }
   
 int main(int argc, char **argv, char **env)  int main(int argc, char **argv, char **env)
 {  {
 #ifdef HAS_OS  #ifdef HAS_OS
Line 835 
Line 1196 
 #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.50  
changed lines
  Added in v.1.77
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help