[gforth] / gforth / engine / main.c  

gforth: gforth/engine/main.c

Diff for /gforth/engine/main.c between version 1.67 and 1.92

version 1.67, Fri Oct 4 19:17:06 2002 UTC version 1.92, Fri Jan 10 21:19:59 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 81 
Line 118 
 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 */  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_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,  static int no_dynamic=NO_DYNAMIC_DEFAULT; /* if true, no code is generated
    but not with 3.2) */                                               dynamically */
 #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
Line 118 
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 142 
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 171 
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|0x4000)            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 182 
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]:=CFA(%x)\n",  /*            printf("Code field generation image[%x]:=CFA(%x)\n",
                      i, CF(image[i])); */                       i, CF(image[i])); */
               if (CF((token | 0x4000))<max_symbols) {                if (CF((token | 0x4000))<max_symbols) {
                 image[i]=(Cell)CFA(CF(token));                  image[i]=(Cell)CFA(CF(token));
 #ifdef DIRECT_THREADED  #ifdef DIRECT_THREADED
                 if ((token & 0x4000) == 0) /* threade code, no CFA */                  if ((token & 0x4000) == 0) /* threade code, no CFA */
                   image[i] = (Cell)compile_prim((Label)image[i]);                    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],PACKAGE_VERSION);
               }
             } 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  #endif
               } 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 %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 {          } 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 208 
Line 272 
       }        }
     }      }
   }    }
     finish_code();
   ((ImageHeader*)(image))->base = (Address) image;    ((ImageHeader*)(image))->base = (Address) image;
 }  }
   
Line 272 
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 370 
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 = start_flush = 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 428 
Line 495 
   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 442 
Line 508 
           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[])
 {  {
   int i;    int i;
   Label *symbols2;  #ifndef NO_DYNAMIC
     Label *symbols2, *symbols3, *ends1;
   static char superend[]={    static char superend[]={
 #include "prim_superend.i"  #include "prim_superend.i"
   };    };
   #endif
   
   if (debug)    if (debug)
 #ifdef __VERSION__  #ifdef __VERSION__
Line 472 
Line 566 
     ;      ;
   npriminfos = i;    npriminfos = i;
   
 #if defined(IS_NEXT_JUMP) && !defined(DOUBLY_INDIRECT)  #ifndef NO_DYNAMIC
   if (no_dynamic)    if (no_dynamic)
     return;      return;
   symbols2=engine2(0,0,0,0,0);    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));    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]|no_super;      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;
         }
     }      }
     pi->length = prim_len;  
     /* 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)        if (debug)
         fprintf(stderr,"Primitive %d not relocatable: memcmp(%p, %p, %d)\n",        fprintf(stderr,"\n");
                 i, symbols1[i], symbols2[i], prim_len);    }
     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
   }
   
   #ifndef NO_DYNAMIC
   void flush_to_here(void)
   {
     FLUSH_ICACHE(start_flush, code_here-start_flush);
     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;
   
     if (code_area+code_area_size < code_here+pi->length+pi->restlength) {
       struct code_block_list *p;
       append_jump();
       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 {      } else {
       pi->start = symbols1[i];        p = *next_code_blockp;
       if (debug)        code_here = start_flush = code_area = p->block;
         fprintf(stderr,"Primitive %d relocatable: start %p, length %ld, super_end %d\n",  
                 i, pi->start, pi->length, pi->super_end);  
     }      }
       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  #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;
         return -1;
       }
     }
     return -no_dynamic;
   #endif /* !defined(NO_DYNAMIC) */
 }  }
   
 Label compile_prim(Label prim)  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;
     }
     /* 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)  #if defined(DOUBLY_INDIRECT)
     Label prim=(Label)*start;
   if (prim<((Label)(xts+DOESJUMP)) || prim>((Label)(xts+npriminfos))) {    if (prim<((Label)(xts+DOESJUMP)) || prim>((Label)(xts+npriminfos))) {
     fprintf(stderr,"compile_prim encountered xt %p\n", prim);      fprintf(stderr,"compile_prim encountered xt %p\n", prim);
     return prim;      *start=(Cell)prim;
   } else      return;
     return prim-((Label)xts)+((Label)vm_prims);    } else {
 #elif defined(IND_JUMP_LENGTH) && !defined(VM_PROFILING) && !defined(INDIRECT_THREADED)      *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;    unsigned i;
   Address old_code_here=code_here;    Address old_code_here;
   static Address last_jump=0;  
   
   i = ((Xt)prim)-vm_prims;    i = ((Xt)prim)-vm_prims;
   prim = *(Xt)prim;    prim = *(Xt)prim;
   if (no_dynamic)    if (no_dynamic) {
     return prim;      *start = (Cell)prim;
   if (i>=npriminfos || priminfos[i].start == 0) { /* not a relocatable prim */      return;
     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;  
       FLUSH_ICACHE(start_flush, code_here-start_flush);  
       start_flush=code_here;  
     }      }
     return prim;    if (i>=npriminfos || priminfos[i].start == 0) { /* not a relocatable prim */
       append_jump();
       *start = (Cell)prim;
       return;
   }    }
   assert(priminfos[i].start = prim);    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;
   if (last_jump == 0) {    *start = (Cell)old_code_here;
     FLUSH_ICACHE(start_flush, code_here-start_flush);    return;
     start_flush=code_here;  
   }  
   return (Label)old_code_here;  
 #else /* !defined(DOUBLY_INDIRECT), no code replication */  #else /* !defined(DOUBLY_INDIRECT), no code replication */
     Label prim=(Label)*start;
 #if !defined(INDIRECT_THREADED)  #if !defined(INDIRECT_THREADED)
   prim = *(Xt)prim;    prim = *(Xt)prim;
 #endif  #endif
   return prim;    *start = (Cell)prim;
     return;
 #endif /* !defined(DOUBLY_INDIRECT) */  #endif /* !defined(DOUBLY_INDIRECT) */
 }  }
   
 #ifdef PRINT_SUPER_LENGTHS  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)  Cell prim_length(Cell prim)
 {  {
   return priminfos[prim+DOESJUMP+1].length;    return priminfos[prim+DOESJUMP+1].length;
Line 608 
Line 977 
   
   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 650 
Line 1019 
   alloc_stacks((ImageHeader *)imp);    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 687 
Line 1056 
   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 719 
Line 1080 
   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 730 
Line 1091 
   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 841 
Line 1202 
     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 878 
Line 1239 
 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

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help