[gforth] / gforth / engine / main.c  

gforth: gforth/engine/main.c

Diff for /gforth/engine/main.c between version 1.84 and 1.151

version 1.84, Fri Dec 27 17:19:34 2002 UTC version 1.151, Sun Jul 31 20:27:42 2005 UTC
Line 1 
Line 1 
 /* command line interpretation, image loading etc. for Gforth  /* command line interpretation, image loading etc. for Gforth
   
   
   Copyright (C) 1995,1996,1997,1998,2000 Free Software Foundation, Inc.    Copyright (C) 1995,1996,1997,1998,2000,2003,2004 Free Software Foundation, Inc.
   
   This file is part of Gforth.    This file is part of Gforth.
   
Line 35 
Line 35 
 #include <fcntl.h>  #include <fcntl.h>
 #include <assert.h>  #include <assert.h>
 #include <stdlib.h>  #include <stdlib.h>
   #include <signal.h>
 #ifndef STANDALONE  #ifndef STANDALONE
 #if HAVE_SYS_MMAN_H  #if HAVE_SYS_MMAN_H
 #include <sys/mman.h>  #include <sys/mman.h>
Line 46 
Line 47 
 #include <systypes.h>  #include <systypes.h>
 #endif  #endif
   
   typedef enum prim_num {
   /* definitions of N_execute etc. */
   #include PRIM_NUM_I
     N_START_SUPER
   } PrimNum;
   
 /* global variables for engine.c  /* global variables for engine.c
    We put them here because engine.c is compiled several times in     We put them here because engine.c is compiled several times in
    different ways for the same engine. */     different ways for the same engine. */
Line 53 
Line 60 
 Float *FP;  Float *FP;
 Address UP=NULL;  Address UP=NULL;
   
   #ifdef HAS_FFCALL
   Cell *RP;
   Address LP;
   
   #include <callback.h>
   
   va_alist clist;
   
   void engine_callback(Xt* fcall, void * alist)
   {
     /* save global valiables */
     Cell *rp = RP;
     Cell *sp = SP;
     Float *fp = FP;
     Address lp = LP;
   
     clist = (va_alist)alist;
   
     engine(fcall, sp, rp, fp, lp);
   
     /* restore global variables */
     RP = rp;
     SP = sp;
     FP = fp;
     LP = lp;
   }
   #endif
   
 #ifdef GFORTH_DEBUGGING  #ifdef GFORTH_DEBUGGING
 /* define some VM registers as global variables, so they survive exceptions;  /* define some VM registers as global variables, so they survive exceptions;
    global register variables are not up to the task (according to the     global register variables are not up to the task (according to the
Line 118 
Line 153 
 int optind = 1;  int optind = 1;
 #endif  #endif
   
 #define CODE_BLOCK_SIZE (64*1024)  #define CODE_BLOCK_SIZE (4096*1024) /* !! overflow handling for -native */
 Address code_area=0;  Address code_area=0;
 Cell code_area_size = CODE_BLOCK_SIZE;  Cell code_area_size = CODE_BLOCK_SIZE;
 Address code_here=NULL+CODE_BLOCK_SIZE; /* does for code-area what HERE  Address code_here=NULL+CODE_BLOCK_SIZE; /* does for code-area what HERE
                                            does for the dictionary */                                             does for the dictionary */
 Address start_flush=0; /* start of unflushed code */  Address start_flush=NULL; /* start of unflushed code */
 Cell last_jump=0; /* if the last prim was compiled without jump, this  Cell last_jump=0; /* if the last prim was compiled without jump, this
                      is it's number, otherwise this contains 0 */                       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 */
 static int no_dynamic=NO_DYNAMIC_DEFAULT; /* if true, no code is generated  static int no_dynamic=NO_DYNAMIC_DEFAULT; /* if true, no code is generated
                                              dynamically */                                               dynamically */
   static int print_metrics=0; /* if true, print metrics on exit */
   static int static_super_number = 10000000; /* number of ss used if available */
   #define MAX_STATE 4 /* maximum number of states */
   static int maxstates = MAX_STATE; /* number of states for stack caching */
   static int ss_greedy = 0; /* if true: use greedy, not optimal ss selection */
   static int diag = 0; /* if true: print diagnostic informations */
   static int relocs = 0;
   static int nonrelocs = 0;
   
 #ifdef HAS_DEBUG  #ifdef HAS_DEBUG
 int debug=0;  int debug=0;
   # define debugp(x...) if (debug) fprintf(x);
 #else  #else
 # define perror(x...)  # define perror(x...)
 # define fprintf(x...)  # define fprintf(x...)
   # define debugp(x...)
 #endif  #endif
   
 ImageHeader *gforth_header;  ImageHeader *gforth_header;
Line 144 
Line 189 
 Label *xts; /* same content as vm_prims, but should only be used for xts */  Label *xts; /* same content as vm_prims, but should only be used for xts */
 #endif  #endif
   
   #ifndef NO_DYNAMIC
   #define MAX_IMMARGS 2
   
   typedef struct {
     Label start; /* NULL if not relocatable */
     Cell length; /* only includes the jump iff superend is true*/
     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. */
     Cell nimmargs;
     struct immarg {
       Cell offset; /* offset of immarg within prim */
       char rel;    /* true if immarg is relative */
     } immargs[MAX_IMMARGS];
   } PrimInfo;
   
   PrimInfo *priminfos;
   PrimInfo **decomp_prims;
   
   const char const* const prim_names[]={
   #include PRIM_NAMES_I
   };
   
   void init_ss_cost(void);
   
   static int is_relocatable(int p)
   {
     return !no_dynamic && priminfos[p].start != NULL;
   }
   #else /* defined(NO_DYNAMIC) */
   static int is_relocatable(int p)
   {
     return 0;
   }
   #endif /* defined(NO_DYNAMIC) */
   
 #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 151 
Line 232 
 }  }
 #endif  #endif
   
   static Cell max(Cell a, Cell b)
   {
     return a>b?a:b;
   }
   
   static Cell min(Cell a, Cell b)
   {
     return a<b?a:b;
   }
   
 /* 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
Line 178 
Line 269 
  * 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
  */   */
   
 void relocate(Cell *image, const char *bitstring,  Cell groups[32] = {
               int size, int base, Label symbols[])    0,
     0
   #undef GROUP
   #undef GROUPADD
   #define GROUPADD(n) +n
   #define GROUP(x, n) , 0
   #include PRIM_GRP_I
   #undef GROUP
   #undef GROUPADD
   #define GROUP(x, n)
   #define GROUPADD(n)
   };
   
   unsigned char *branch_targets(Cell *image, const unsigned char *bitstring,
                                 int size, Cell base)
        /* produce a bitmask marking all the branch targets */
   {
     int i=0, j, k, steps=(((size-1)/sizeof(Cell))/RELINFOBITS)+1;
     Cell token;
     unsigned char bits;
     unsigned char *result=malloc(steps);
   
     memset(result, 0, steps);
     for(k=0; k<steps; k++) {
       for(j=0, bits=bitstring[k]; j<RELINFOBITS; j++, i++, bits<<=1) {
         if(bits & (1U << (RELINFOBITS-1))) {
           assert(i*sizeof(Cell) < size);
           token=image[i];
           if (token>=base) { /* relocatable address */
             UCell bitnum=(token-base)/sizeof(Cell);
             result[bitnum/RELINFOBITS] |= 1U << ((~bitnum)&(RELINFOBITS-1));
           }
         }
       }
     }
     return result;
   }
   
   void relocate(Cell *image, const unsigned char *bitstring,
                 int size, Cell base, Label symbols[])
 {  {
   int i=0, j, k, steps=(size/sizeof(Cell))/RELINFOBITS;    int i=0, j, k, steps=(((size-1)/sizeof(Cell))/RELINFOBITS)+1;
   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));
     unsigned char *targets = branch_targets(image, bitstring, size, base);
   
     /* group index into table */
     if(groups[31]==0) {
       int groupsum=0;
       for(i=0; i<32; i++) {
         groupsum += groups[i];
         groups[i] = groupsum;
         /* printf("group[%d]=%d\n",i,groupsum); */
       }
       i=0;
     }
   
 /* 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); */
   
   for (max_symbols=DOESJUMP+1; symbols[max_symbols]!=0; max_symbols++)    for (max_symbols=0; symbols[max_symbols]!=0; max_symbols++)
     ;      ;
   max_symbols--;    max_symbols--;
   size/=sizeof(Cell);  
   
   for(k=0; k<=steps; k++) {    for(k=0; k<steps; k++) {
     for(j=0, bits=bitstring[k]; j<RELINFOBITS; j++, i++, bits<<=1) {      for(j=0, bits=bitstring[k]; j<RELINFOBITS; j++, i++, bits<<=1) {
       /*      fprintf(stderr,"relocate: image[%d]\n", i);*/        /*      fprintf(stderr,"relocate: image[%d]\n", i);*/
       if((i < size) && (bits & (1U << (RELINFOBITS-1)))) {        if(bits & (1U << (RELINFOBITS-1))) {
           assert(i*sizeof(Cell) < size);
         /* 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 218 
Line 362 
             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 */
                     if (targets[k] & (1U<<(RELINFOBITS-1-j)))
                       compile_prim1(0);
                   compile_prim1(&image[i]);                    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],PACKAGE_VERSION);                  fprintf(stderr,"Primitive %ld used in this image at $%lx (offset $%x) is not implemented by this\n engine (%s); executing this code will crash.\n",(long)CF(token),(long)&image[i], i, PACKAGE_VERSION);
             }              }
         else {            } else {
           // if base is > 0: 0 is a null reference so don't adjust              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 */
                   if (targets[k] & (1U<<(RELINFOBITS-1-j)))
                     compile_prim1(0);
                   compile_prim1(&image[i]);
                 }
   #endif
               } else
                 fprintf(stderr,"Primitive %lx, %d of group %d used in this image at $%lx (offset $%x) is not implemented by this\n engine (%s); executing this code will crash.\n", (long)-token, tok, group, (long)&image[i],i,PACKAGE_VERSION);
             }
           } else {
             /* 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 244 
Line 409 
       }        }
     }      }
   }    }
     free(targets);
   finish_code();    finish_code();
   ((ImageHeader*)(image))->base = (Address) image;    ((ImageHeader*)(image))->base = (Address) image;
 }  }
Line 281 
Line 447 
     exit(1);      exit(1);
   }    }
   r = (Address)((((Cell)r)+(sizeof(Float)-1))&(-sizeof(Float)));    r = (Address)((((Cell)r)+(sizeof(Float)-1))&(-sizeof(Float)));
   if (debug)    debugp(stderr, "malloc succeeds, address=$%lx\n", (long)r);
     fprintf(stderr, "malloc succeeds, address=$%lx\n", (long)r);  
   return r;    return r;
 }  }
   
Line 290 
Line 455 
 void after_alloc(Address r, Cell size)  void after_alloc(Address r, Cell size)
 {  {
   if (r != (Address)-1) {    if (r != (Address)-1) {
     if (debug)      debugp(stderr, "success, address=$%lx\n", (long) r);
       fprintf(stderr, "success, address=$%lx\n", (long) r);  
     if (pagesize != 1)      if (pagesize != 1)
       next_address = (Address)(((((Cell)r)+size-1)&-pagesize)+2*pagesize); /* leave one page unmapped */        next_address = (Address)(((((Cell)r)+size-1)&-pagesize)+2*pagesize); /* leave one page unmapped */
   } else {    } else {
     if (debug)      debugp(stderr, "failed: %s\n", strerror(errno));
       fprintf(stderr, "failed: %s\n", strerror(errno));  
   }    }
 }  }
   
Line 309 
Line 472 
 #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 316 
Line 482 
   Address r;    Address r;
   
 #if defined(MAP_ANON)  #if defined(MAP_ANON)
   if (debug)    debugp(stderr,"try mmap($%lx, $%lx, ..., MAP_ANON, ...); ", (long)next_address, (long)size);
     fprintf(stderr,"try mmap($%lx, $%lx, ..., MAP_ANON, ...); ", (long)next_address, (long)size);  
   r = mmap(next_address, size, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_ANON|MAP_PRIVATE, -1, 0);    r = mmap(next_address, size, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_ANON|MAP_PRIVATE, -1, 0);
 #else /* !defined(MAP_ANON) */  #else /* !defined(MAP_ANON) */
   /* Ultrix (at least) does not define MAP_FILE and MAP_PRIVATE (both are    /* Ultrix (at least) does not define MAP_FILE and MAP_PRIVATE (both are
Line 328 
Line 493 
     dev_zero = open("/dev/zero", O_RDONLY);      dev_zero = open("/dev/zero", O_RDONLY);
   if (dev_zero == -1) {    if (dev_zero == -1) {
     r = MAP_FAILED;      r = MAP_FAILED;
     if (debug)      debugp(stderr, "open(\"/dev/zero\"...) failed (%s), no mmap; ",
       fprintf(stderr, "open(\"/dev/zero\"...) failed (%s), no mmap; ",  
               strerror(errno));                strerror(errno));
   } else {    } else {
     if (debug)      debugp(stderr,"try mmap($%lx, $%lx, ..., MAP_FILE, dev_zero, ...); ", (long)next_address, (long)size);
       fprintf(stderr,"try mmap($%lx, $%lx, ..., MAP_FILE, dev_zero, ...); ", (long)next_address, (long)size);  
     r=mmap(next_address, size, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_FILE|MAP_PRIVATE, dev_zero, 0);      r=mmap(next_address, size, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_FILE|MAP_PRIVATE, dev_zero, 0);
   }    }
 #endif /* !defined(MAP_ANON) */  #endif /* !defined(MAP_ANON) */
Line 348 
Line 511 
   Address r;    Address r;
   
   r=alloc_mmap(size);    r=alloc_mmap(size);
   if (r!=MAP_FAILED)    if (r!=(Address)MAP_FAILED)
     return r;      return r;
 #endif /* HAVE_MMAP */  #endif /* HAVE_MMAP */
   /* use malloc as fallback */    /* use malloc as fallback */
Line 362 
Line 525 
 #if defined(HAVE_MMAP)  #if defined(HAVE_MMAP)
   if (offset==0) {    if (offset==0) {
     image=alloc_mmap(dictsize);      image=alloc_mmap(dictsize);
     if (debug)      if (image != (Address)MAP_FAILED) {
       fprintf(stderr,"try mmap($%lx, $%lx, ..., MAP_FIXED|MAP_FILE, imagefile, 0); ", (long)image, (long)imagesize);        Address image1;
     image = mmap(image, imagesize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_FIXED|MAP_FILE|MAP_PRIVATE, fileno(file), 0);        debugp(stderr,"try mmap($%lx, $%lx, ..., MAP_FIXED|MAP_FILE, imagefile, 0); ", (long)image, (long)imagesize);
     after_alloc(image,dictsize);        image1 = mmap(image, imagesize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_FIXED|MAP_FILE|MAP_PRIVATE, fileno(file), 0);
         after_alloc(image1,dictsize);
         if (image1 == (Address)MAP_FAILED)
           goto read_image;
       }
   }    }
 #endif /* defined(HAVE_MMAP) */  #endif /* defined(HAVE_MMAP) */
   if (image == MAP_FAILED) {    if (image == (Address)MAP_FAILED) {
     image = my_alloc(dictsize+offset)+offset;      image = my_alloc(dictsize+offset)+offset;
     read_image:
     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 426 
Line 594 
 #endif  #endif
   
   /* ensure that the cached elements (if any) are accessible */    /* ensure that the cached elements (if any) are accessible */
   IF_spTOS(sp0--);  #if !(defined(GFORTH_DEBUGGING) || defined(INDIRECT_THREADED) || defined(DOUBLY_INDIRECT) || defined(VM_PROFILING))
     sp0 -= 8; /* make stuff below bottom accessible for stack caching */
   #endif
   IF_fpTOS(fp0--);    IF_fpTOS(fp0--);
   
   for(;stack>0;stack--)    for(;stack>0;stack--)
Line 445 
Line 615 
     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); */      debugp(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)saved_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) */
       debugp(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 477 
Line 651 
           1 << ((sizebyte >> 5) & 3));            1 << ((sizebyte >> 5) & 3));
 }  }
   
 #define MAX_IMMARGS 2  /* static superinstruction stuff */
   
 #ifndef NO_DYNAMIC  struct cost { /* super_info might be a more accurate name */
 typedef struct {    char loads;       /* number of stack loads */
   Label start;    char stores;      /* number of stack stores */
   Cell length; /* only includes the jump iff superend is true*/    char updates;     /* number of stack pointer updates */
   Cell restlength; /* length of the rest (i.e., the jump or (on superend) 0) */    char branch;      /* is it a branch (SET_IP) */
   char superend; /* true if primitive ends superinstruction, i.e.,    unsigned char state_in;    /* state on entry */
                      unconditional branch, execute, etc. */    unsigned char state_out;   /* state on exit */
   Cell nimmargs;    unsigned char imm_ops;     /* number of immediate operands */
   struct immarg {    short offset;     /* offset into super2 table */
     Cell offset; /* offset of immarg within prim */    unsigned char length;      /* number of components */
     char rel;    /* true if immarg is relative */  };
   } immargs[MAX_IMMARGS];  
 } PrimInfo;  
   
 PrimInfo *priminfos;  PrimNum super2[] = {
 PrimInfo **decomp_prims;  #include SUPER2_I
   };
   
   struct cost super_costs[] = {
   #include COSTS_I
   };
   
   struct super_state {
     struct super_state *next;
     PrimNum super;
   };
   
   #define HASH_SIZE 256
   
 int compare_priminfo_length(PrimInfo **a, PrimInfo **b)  struct super_table_entry {
     struct super_table_entry *next;
     PrimNum *start;
     short length;
     struct super_state *ss_list; /* list of supers */
   } *super_table[HASH_SIZE];
   int max_super=2;
   
   struct super_state *state_transitions=NULL;
   
   int hash_super(PrimNum *start, int length)
 {  {
     int i, r;
   
     for (i=0, r=0; i<length; i++) {
       r <<= 1;
       r += start[i];
     }
     return r & (HASH_SIZE-1);
   }
   
   struct super_state **lookup_super(PrimNum *start, int length)
   {
     int hash=hash_super(start,length);
     struct super_table_entry *p = super_table[hash];
   
     /* assert(length >= 2); */
     for (; p!=NULL; p = p->next) {
       if (length == p->length &&
           memcmp((char *)p->start, (char *)start, length*sizeof(PrimNum))==0)
         return &(p->ss_list);
     }
     return NULL;
   }
   
   void prepare_super_table()
   {
     int i;
     int nsupers = 0;
   
     for (i=0; i<sizeof(super_costs)/sizeof(super_costs[0]); i++) {
       struct cost *c = &super_costs[i];
       if ((c->length < 2 || nsupers < static_super_number) &&
           c->state_in < maxstates && c->state_out < maxstates) {
         struct super_state **ss_listp= lookup_super(super2+c->offset, c->length);
         struct super_state *ss = malloc(sizeof(struct super_state));
         ss->super= i;
         if (c->offset==N_noop && i != N_noop) {
           if (is_relocatable(i)) {
             ss->next = state_transitions;
             state_transitions = ss;
           }
         } else if (ss_listp != NULL) {
           ss->next = *ss_listp;
           *ss_listp = ss;
         } else {
           int hash = hash_super(super2+c->offset, c->length);
           struct super_table_entry **p = &super_table[hash];
           struct super_table_entry *e = malloc(sizeof(struct super_table_entry));
           ss->next = NULL;
           e->next = *p;
           e->start = super2 + c->offset;
           e->length = c->length;
           e->ss_list = ss;
           *p = e;
         }
         if (c->length > max_super)
           max_super = c->length;
         if (c->length >= 2)
           nsupers++;
       }
     }
     debugp(stderr, "Using %d static superinsts\n", nsupers);
   }
   
   /* dynamic replication/superinstruction stuff */
   
   #ifndef NO_DYNAMIC
   int compare_priminfo_length(const void *_a, const void *_b)
   {
     PrimInfo **a = (PrimInfo **)_a;
     PrimInfo **b = (PrimInfo **)_b;
   Cell diff = (*a)->length - (*b)->length;    Cell diff = (*a)->length - (*b)->length;
   if (diff)    if (diff)
     return diff;      return diff;
Line 506 
Line 770 
           of (char) and @ instead of >code-address */            of (char) and @ instead of >code-address */
     return (*b)->start - (*a)->start;      return (*b)->start - (*a)->start;
 }  }
   #endif /* !defined(NO_DYNAMIC) */
   
   static char MAYBE_UNUSED superend[]={
   #include PRIM_SUPEREND_I
   };
   
 #endif /* defined(NO_DYNAMIC) */  
 Cell npriminfos=0;  Cell npriminfos=0;
   
   Label goto_start;
   Cell goto_len;
   
   int compare_labels(const void *pa, const void *pb)
   {
     Label a = *(Label *)pa;
     Label b = *(Label *)pb;
     return a-b;
   }
   
   Label bsearch_next(Label key, Label *a, UCell n)
        /* a is sorted; return the label >=key that is the closest in a;
           return NULL if there is no label in a >=key */
   {
     int mid = (n-1)/2;
     if (n<1)
       return NULL;
     if (n == 1) {
       if (a[0] < key)
         return NULL;
       else
         return a[0];
     }
     if (a[mid] < key)
       return bsearch_next(key, a+mid+1, n-mid-1);
     else
       return bsearch_next(key, a, mid+1);
   }
   
 void check_prims(Label symbols1[])  void check_prims(Label symbols1[])
 {  {
   int i;    int i;
   Label *symbols2, *symbols3, *ends1;  #ifndef NO_DYNAMIC
   static char superend[]={    Label *symbols2, *symbols3, *ends1, *ends1j, *ends1jsorted, *goto_p;
 #include "prim_superend.i"    int nends1j;
   };  #endif
   
   if (debug)    if (debug)
 #ifdef __VERSION__  #ifdef __VERSION__
Line 527 
Line 823 
 #define str(s) #s  #define str(s) #s
   fprintf(stderr, "Compiled with gcc-" xstr(__GNUC__) "." xstr(__GNUC_MINOR__) "\n");    fprintf(stderr, "Compiled with gcc-" xstr(__GNUC__) "." xstr(__GNUC_MINOR__) "\n");
 #endif  #endif
   for (i=DOESJUMP+1; symbols1[i+1]!=0; i++)    for (i=0; symbols1[i]!=0; i++)
     ;      ;
   npriminfos = i;    npriminfos = i;
   
Line 540 
Line 836 
 #else  #else
   symbols3=symbols1;    symbols3=symbols1;
 #endif  #endif
   ends1 = symbols1+i+1-DOESJUMP;    ends1 = symbols1+i+1;
     ends1j =   ends1+i;
     goto_p = ends1j+i+1; /* goto_p[0]==before; ...[1]==after;*/
     nends1j = i+1;
     ends1jsorted = (Label *)alloca(nends1j*sizeof(Label));
     memcpy(ends1jsorted,ends1j,nends1j*sizeof(Label));
     qsort(ends1jsorted, nends1j, sizeof(Label), compare_labels);
   
     /* check whether the "goto *" is relocatable */
     goto_len = goto_p[1]-goto_p[0];
     debugp(stderr, "goto * %p %p len=%ld\n",
            goto_p[0],symbols2[goto_p-symbols1],goto_len);
     if (memcmp(goto_p[0],symbols2[goto_p-symbols1],goto_len)!=0) { /* unequal */
       no_dynamic=1;
       debugp(stderr,"  not relocatable, disabling dynamic code generation\n");
       init_ss_cost();
       return;
     }
     goto_start = goto_p[0];
   
   priminfos = calloc(i,sizeof(PrimInfo));    priminfos = calloc(i,sizeof(PrimInfo));
   for (i=DOESJUMP+1; symbols1[i+1]!=0; i++) {    for (i=0; symbols1[i]!=0; i++) {
     int prim_len = ends1[i]-symbols1[i];      int prim_len = ends1[i]-symbols1[i];
     PrimInfo *pi=&priminfos[i];      PrimInfo *pi=&priminfos[i];
     int j=0;      int j=0;
     char *s1 = (char *)symbols1[i];      char *s1 = (char *)symbols1[i];
     char *s2 = (char *)symbols2[i];      char *s2 = (char *)symbols2[i];
     char *s3 = (char *)symbols3[i];      char *s3 = (char *)symbols3[i];
       Label endlabel = bsearch_next(symbols1[i]+1,ends1jsorted,nends1j);
   
     pi->start = s1;      pi->start = s1;
     pi->superend = superend[i-DOESJUMP-1]|no_super;      pi->superend = superend[i]|no_super;
     if (pi->superend)  
       pi->length = symbols1[i+1]-symbols1[i];  
     else  
       pi->length = prim_len;        pi->length = prim_len;
     pi->restlength = symbols1[i+1] - symbols1[i] - pi->length;      pi->restlength = endlabel - symbols1[i] - pi->length;
     pi->nimmargs = 0;      pi->nimmargs = 0;
     if (debug)      relocs++;
       fprintf(stderr, "Prim %3d @ %p %p %p, length=%3d restlength=%2d superend=%1d",      debugp(stderr, "%-15s %3d %p %p %p len=%3ld restlen=%2ld s-end=%1d",
               i, s1, s2, s3, pi->length, pi->restlength, pi->superend);                prim_names[i], i, s1, s2, s3, (long)(pi->length), (long)(pi->restlength), pi->superend);
     assert(prim_len>=0);      if (endlabel == NULL) {
         pi->start = NULL; /* not relocatable */
         if (pi->length<0) pi->length=100;
         debugp(stderr,"\n   non_reloc: no J label > start found\n");
         relocs--;
         nonrelocs++;
         continue;
       }
       if (ends1[i] > endlabel && !pi->superend) {
         pi->start = NULL; /* not relocatable */
         pi->length = endlabel-symbols1[i];
         debugp(stderr,"\n   non_reloc: there is a J label before the K label (restlength<0)\n");
         relocs--;
         nonrelocs++;
         continue;
       }
       if (ends1[i] < pi->start && !pi->superend) {
         pi->start = NULL; /* not relocatable */
         pi->length = endlabel-symbols1[i];
         debugp(stderr,"\n   non_reloc: K label before I label (length<0)\n");
         relocs--;
         nonrelocs++;
         continue;
       }
       assert(pi->length>=0);
       assert(pi->restlength >=0);
     while (j<(pi->length+pi->restlength)) {      while (j<(pi->length+pi->restlength)) {
       if (s1[j]==s3[j]) {        if (s1[j]==s3[j]) {
         if (s1[j] != s2[j]) {          if (s1[j] != s2[j]) {
           pi->start = NULL; /* not relocatable */            pi->start = NULL; /* not relocatable */
           if (debug)            debugp(stderr,"\n   non_reloc: engine1!=engine2 offset %3d",j);
             fprintf(stderr,"\n   non_reloc: engine1!=engine2 offset %3d",j);  
           /* assert(j<prim_len); */            /* assert(j<prim_len); */
             relocs--;
             nonrelocs++;
           break;            break;
         }          }
         j++;          j++;
Line 579 
Line 918 
         ia->offset=j;          ia->offset=j;
         if ((~*(Cell *)&(s1[j]))==*(Cell *)&(s3[j])) {          if ((~*(Cell *)&(s1[j]))==*(Cell *)&(s3[j])) {
           ia->rel=0;            ia->rel=0;
           if (debug)            debugp(stderr,"\n   absolute immarg: offset %3d",j);
             fprintf(stderr,"\n   absolute immarg: offset %3d",j);  
         } else if ((&(s1[j]))+(*(Cell *)&(s1[j]))+4 ==          } else if ((&(s1[j]))+(*(Cell *)&(s1[j]))+4 ==
                    symbols1[DOESJUMP+1]) {                     symbols1[DOESJUMP+1]) {
           ia->rel=1;            ia->rel=1;
           if (debug)            debugp(stderr,"\n   relative immarg: offset %3d",j);
             fprintf(stderr,"\n   relative immarg: offset %3d",j);  
         } else {          } else {
           pi->start = NULL; /* not relocatable */            pi->start = NULL; /* not relocatable */
           if (debug)            debugp(stderr,"\n   non_reloc: engine1!=engine3 offset %3d",j);
             fprintf(stderr,"\n   non_reloc: engine1!=engine3 offset %3d",j);  
           /* assert(j<prim_len);*/            /* assert(j<prim_len);*/
             relocs--;
             nonrelocs++;
           break;            break;
         }          }
         j+=4;          j+=4;
       }        }
     }      }
     if (debug)      debugp(stderr,"\n");
       fprintf(stderr,"\n");  
   }    }
   decomp_prims = calloc(i,sizeof(PrimInfo *));    decomp_prims = calloc(i,sizeof(PrimInfo *));
   for (i=DOESJUMP+1; i<npriminfos; i++)    for (i=DOESJUMP+1; i<npriminfos; i++)
Line 607 
Line 944 
 #endif  #endif
 }  }
   
 #ifndef NO_DYNAMIC  
 void flush_to_here(void)  void flush_to_here(void)
 {  {
   #ifndef NO_DYNAMIC
     if (start_flush)
   FLUSH_ICACHE(start_flush, code_here-start_flush);    FLUSH_ICACHE(start_flush, code_here-start_flush);
   start_flush=code_here;    start_flush=code_here;
   #endif
 }  }
   
   #ifndef NO_DYNAMIC
 void append_jump(void)  void append_jump(void)
 {  {
   if (last_jump) {    if (last_jump) {
Line 621 
Line 961 
   
     memcpy(code_here, pi->start+pi->length, pi->restlength);      memcpy(code_here, pi->start+pi->length, pi->restlength);
     code_here += pi->restlength;      code_here += pi->restlength;
       memcpy(code_here, goto_start, goto_len);
       code_here += goto_len;
     last_jump=0;      last_jump=0;
     flush_to_here();  
   }    }
 }  }
   
Line 647 
Line 988 
   if (code_area+code_area_size < code_here+pi->length+pi->restlength) {    if (code_area+code_area_size < code_here+pi->length+pi->restlength) {
     struct code_block_list *p;      struct code_block_list *p;
     append_jump();      append_jump();
       flush_to_here();
     if (*next_code_blockp == NULL) {      if (*next_code_blockp == NULL) {
       code_here = start_flush = code_area = my_alloc(code_area_size);        code_here = start_flush = code_area = my_alloc(code_area_size);
       p = (struct code_block_list *)malloc(sizeof(struct code_block_list));        p = (struct code_block_list *)malloc(sizeof(struct code_block_list));
Line 663 
Line 1005 
   }    }
   memcpy(code_here, pi->start, pi->length);    memcpy(code_here, pi->start, pi->length);
   code_here += pi->length;    code_here += pi->length;
   if (pi->superend)  
     flush_to_here();  
   return old_code_here;    return old_code_here;
 }  }
 #endif  #endif
Line 689 
Line 1029 
 #endif /* !defined(NO_DYNAMIC) */  #endif /* !defined(NO_DYNAMIC) */
 }  }
   
 Label decompile_code(Label code)  long dyncodesize(void)
   {
   #ifndef NO_DYNAMIC
     struct code_block_list *p;
     long size=0;
     for (p=code_block_list; p!=NULL; p=p->next) {
       if (code_here >= p->block && code_here < p->block+p->size)
         return size + (code_here - p->block);
       else
         size += p->size;
     }
   #endif /* !defined(NO_DYNAMIC) */
     return 0;
   }
   
   Label decompile_code(Label _code)
 {  {
 #ifdef NO_DYNAMIC  #ifdef NO_DYNAMIC
   return code;    return _code;
 #else /* !defined(NO_DYNAMIC) */  #else /* !defined(NO_DYNAMIC) */
   Cell i;    Cell i;
   struct code_block_list *p;    struct code_block_list *p;
     Address code=_code;
   
   /* first, check if we are in code at all */    /* first, check if we are in code at all */
   for (p = code_block_list;; p = p->next) {    for (p = code_block_list;; p = p->next) {
Line 708 
Line 1064 
   for (i=npriminfos-1; i>DOESJUMP; i--) {    for (i=npriminfos-1; i>DOESJUMP; i--) {
     PrimInfo *pi=decomp_prims[i];      PrimInfo *pi=decomp_prims[i];
     if (pi->start==code || (pi->start && memcmp(code,pi->start,pi->length)==0))      if (pi->start==code || (pi->start && memcmp(code,pi->start,pi->length)==0))
       return pi->start;        return vm_prims[super2[super_costs[pi-priminfos].offset]];
       /* return pi->start;*/
   }    }
   return code;    return code;
 #endif /* !defined(NO_DYNAMIC) */  #endif /* !defined(NO_DYNAMIC) */
Line 718 
Line 1075 
 int nbranchinfos=0;  int nbranchinfos=0;
   
 struct branchinfo {  struct branchinfo {
   Label *targetptr; /* *(bi->targetptr) is the target */    Label **targetpp; /* **(bi->targetpp) is the target */
   Cell *addressptr; /* store the target here */    Cell *addressptr; /* store the target here */
 } branchinfos[100000];  } branchinfos[100000];
   
 int ndoesexecinfos=0;  int ndoesexecinfos=0;
 struct doesexecinfo {  struct doesexecinfo {
   int branchinfo; /* fix the targetptr of branchinfos[...->branchinfo] */    int branchinfo; /* fix the targetptr of branchinfos[...->branchinfo] */
     Label *targetp; /*target for branch (because this is not in threaded code)*/
   Cell *xt; /* cfa of word whose does-code needs calling */    Cell *xt; /* cfa of word whose does-code needs calling */
 } doesexecinfos[10000];  } doesexecinfos[10000];
   
 /* definitions of N_execute etc. */  
 #include "prim_num.i"  
   
 void set_rel_target(Cell *source, Label target)  void set_rel_target(Cell *source, Label target)
 {  {
   *source = ((Cell)target)-(((Cell)source)+4);    *source = ((Cell)target)-(((Cell)source)+4);
 }  }
   
 void register_branchinfo(Label source, Cell targetptr)  void register_branchinfo(Label source, Cell *targetpp)
 {  {
   struct branchinfo *bi = &(branchinfos[nbranchinfos]);    struct branchinfo *bi = &(branchinfos[nbranchinfos]);
   bi->targetptr = (Label *)targetptr;    bi->targetpp = (Label **)targetpp;
   bi->addressptr = (Cell *)source;    bi->addressptr = (Cell *)source;
   nbranchinfos++;    nbranchinfos++;
 }  }
   
 Cell *compile_prim1arg(Cell p)  Address compile_prim1arg(PrimNum p, Cell **argp)
 {  {
   int l = priminfos[p].length;    Address old_code_here=append_prim(p);
   Address old_code_here=code_here;  
   
   assert(vm_prims[p]==priminfos[p].start);    assert(vm_prims[p]==priminfos[p].start);
   append_prim(p);    *argp = (Cell*)(old_code_here+priminfos[p].immargs[0].offset);
   return (Cell*)(old_code_here+priminfos[p].immargs[0].offset);    return old_code_here;
 }  }
   
 Cell *compile_call2(Cell targetptr)  Address compile_call2(Cell *targetpp, Cell **next_code_targetp)
 {  {
   Cell *next_code_target;  
   PrimInfo *pi = &priminfos[N_call2];    PrimInfo *pi = &priminfos[N_call2];
   Address old_code_here = append_prim(N_call2);    Address old_code_here = append_prim(N_call2);
   
   next_code_target = (Cell *)(old_code_here + pi->immargs[0].offset);    *next_code_targetp = (Cell *)(old_code_here + pi->immargs[0].offset);
   register_branchinfo(old_code_here + pi->immargs[1].offset, targetptr);    register_branchinfo(old_code_here + pi->immargs[1].offset, targetpp);
   return next_code_target;    return old_code_here;
 }  }
 #endif  #endif
   
Line 774 
Line 1127 
   compile_prim1(NULL);    compile_prim1(NULL);
   for (i=0; i<ndoesexecinfos; i++) {    for (i=0; i<ndoesexecinfos; i++) {
     struct doesexecinfo *dei = &doesexecinfos[i];      struct doesexecinfo *dei = &doesexecinfos[i];
     branchinfos[dei->branchinfo].targetptr = DOES_CODE1((dei->xt));      dei->targetp = (Label *)DOES_CODE1((dei->xt));
       branchinfos[dei->branchinfo].targetpp = &(dei->targetp);
   }    }
   ndoesexecinfos = 0;    ndoesexecinfos = 0;
   for (i=0; i<nbranchinfos; i++) {    for (i=0; i<nbranchinfos; i++) {
     struct branchinfo *bi=&branchinfos[i];      struct branchinfo *bi=&branchinfos[i];
     set_rel_target(bi->addressptr, *(bi->targetptr));      set_rel_target(bi->addressptr, **(bi->targetpp));
   }    }
   nbranchinfos = 0;    nbranchinfos = 0;
   FLUSH_ICACHE(start_flush, code_here-start_flush);  #else
   start_flush=code_here;    compile_prim1(NULL);
 #endif  #endif
     flush_to_here();
 }  }
   
 void compile_prim1(Cell *start)  #ifdef NO_IP
   Cell compile_prim_dyn(PrimNum p, Cell *tcp)
        /* compile prim #p dynamically (mod flags etc.) and return start
           address of generated code for putting it into the threaded
           code. This function is only called if all the associated
           inline arguments of p are already in place (at tcp[1] etc.) */
 {  {
 #if defined(DOUBLY_INDIRECT)    PrimInfo *pi=&priminfos[p];
   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;      Cell *next_code_target=NULL;
     Address codeaddr;
     Address primstart;
   
     assert(i<npriminfos);    assert(p<npriminfos);
     if (i==N_execute||i==N_perform||i==N_lit_perform) {    if (p==N_execute || p==N_perform || p==N_lit_perform) {
       next_code_target = compile_prim1arg(N_set_next_code);      codeaddr = compile_prim1arg(N_set_next_code, &next_code_target);
     }      primstart = append_prim(p);
     if (i==N_call) {      goto other_prim;
       next_code_target = compile_call2(last_start[1]);    } else if (p==N_call) {
     } else if (i==N_does_exec) {      codeaddr = compile_call2(tcp+1, &next_code_target);
     } else if (p==N_does_exec) {
       struct doesexecinfo *dei = &doesexecinfos[ndoesexecinfos++];        struct doesexecinfo *dei = &doesexecinfos[ndoesexecinfos++];
       *compile_prim1arg(N_lit) = (Cell)PFA(last_start[1]);      Cell *arg;
       codeaddr = compile_prim1arg(N_lit,&arg);
       *arg = (Cell)PFA(tcp[1]);
       /* we cannot determine the callee now (last_start[1] may be a        /* we cannot determine the callee now (last_start[1] may be a
          forward reference), so just register an arbitrary target, and           forward reference), so just register an arbitrary target, and
          register in dei that we need to fix this before resolving           register in dei that we need to fix this before resolving
          branches */           branches */
       dei->branchinfo = nbranchinfos;        dei->branchinfo = nbranchinfos;
       dei->xt = (Cell *)(last_start[1]);      dei->xt = (Cell *)(tcp[1]);
       next_code_target = compile_call2(NULL);      compile_call2(0, &next_code_target);
     } else if (pi->start == NULL) { /* non-reloc */    } else if (!is_relocatable(p)) {
       next_code_target = compile_prim1arg(N_set_next_code);      Cell *branch_target;
       set_rel_target(compile_prim1arg(N_abranch),*(Xt)last_prim);      codeaddr = compile_prim1arg(N_set_next_code, &next_code_target);
       compile_prim1arg(N_branch,&branch_target);
       set_rel_target(branch_target,vm_prims[p]);
     } else {      } else {
       unsigned j;        unsigned j;
       Address old_code_here = append_prim(i);  
   
       codeaddr = primstart = append_prim(p);
     other_prim:
       for (j=0; j<pi->nimmargs; j++) {        for (j=0; j<pi->nimmargs; j++) {
         struct immarg *ia = &(pi->immargs[j]);          struct immarg *ia = &(pi->immargs[j]);
         Cell argval = last_start[pi->nimmargs - j]; /* !! specific to prims */        Cell *argp = tcp + pi->nimmargs - j;
         Cell argval = *argp; /* !! specific to prims */
         if (ia->rel) { /* !! assumption: relative refs are branches */          if (ia->rel) { /* !! assumption: relative refs are branches */
           register_branchinfo(old_code_here + ia->offset, argval);          register_branchinfo(primstart + ia->offset, argp);
         } else /* plain argument */          } else /* plain argument */
           *(Cell *)(old_code_here + ia->offset) = argval;          *(Cell *)(primstart + ia->offset) = argval;
       }        }
     }      }
     if (next_code_target!=NULL)      if (next_code_target!=NULL)
       *next_code_target = (Cell)code_here;        *next_code_target = (Cell)code_here;
     return (Cell)codeaddr;
   }    }
   if (start) {  #else /* !defined(NO_IP) */
     last_prim = (Xt)*start;  Cell compile_prim_dyn(PrimNum p, Cell *tcp)
     *start = (Cell)code_here;       /* compile prim #p dynamically (mod flags etc.) and return start
   }          address of generated code for putting it into the threaded code */
   last_start = start;  {
   return;    Cell static_prim = (Cell)vm_prims[p];
 #elif !defined(NO_DYNAMIC)  #if defined(NO_DYNAMIC)
   Label prim=(Label)*start;    return static_prim;
   unsigned i;  #else /* !defined(NO_DYNAMIC) */
   Address old_code_here;    Address old_code_here;
   
   i = ((Xt)prim)-vm_prims;    if (no_dynamic)
   prim = *(Xt)prim;      return static_prim;
   if (no_dynamic) {    if (p>=npriminfos || !is_relocatable(p)) {
     *start = (Cell)prim;      append_jump();
     return;      return static_prim;
   }    }
   if (i>=npriminfos || priminfos[i].start == 0) { /* not a relocatable prim */    old_code_here = append_prim(p);
     last_jump = p;
     if (priminfos[p].superend)
     append_jump();      append_jump();
     *start = (Cell)prim;    return (Cell)old_code_here;
     return;  #endif  /* !defined(NO_DYNAMIC) */
   }
   #endif /* !defined(NO_IP) */
   
   #ifndef NO_DYNAMIC
   int cost_codesize(int prim)
   {
     return priminfos[prim].length;
   }    }
   assert(priminfos[i].start = prim);  
 #ifdef ALIGN_CODE  
   ALIGN_CODE;  
 #endif  
   assert(prim==priminfos[i].start);  
   old_code_here = append_prim(i);  
   last_jump = (priminfos[i].superend) ? 0 : i;  
   *start = (Cell)old_code_here;  
   return;  
 #else /* !defined(DOUBLY_INDIRECT), no code replication */  
   Label prim=(Label)*start;  
 #if !defined(INDIRECT_THREADED)  
   prim = *(Xt)prim;  
 #endif  #endif
   *start = (Cell)prim;  
   return;  int cost_ls(int prim)
 #endif /* !defined(DOUBLY_INDIRECT) */  {
     struct cost *c = super_costs+prim;
   
     return c->loads + c->stores;
 }  }
   
 Label compile_prim(Label prim)  int cost_lsu(int prim)
 {  {
   Cell x=(Cell)prim;    struct cost *c = super_costs+prim;
   assert(0);  
   compile_prim1(&x);    return c->loads + c->stores + c->updates;
   return (Label)x;  }
   
   int cost_nexts(int prim)
   {
     return 1;
   }
   
   typedef int Costfunc(int);
   Costfunc *ss_cost =  /* cost function for optimize_bb */
   #ifdef NO_DYNAMIC
   cost_lsu;
   #else
   cost_codesize;
   #endif
   
   struct {
     Costfunc *costfunc;
     char *metricname;
     long sum;
   } cost_sums[] = {
   #ifndef NO_DYNAMIC
     { cost_codesize, "codesize", 0 },
   #endif
     { cost_ls,       "ls",       0 },
     { cost_lsu,      "lsu",      0 },
     { cost_nexts,    "nexts",    0 }
   };
   
   #ifndef NO_DYNAMIC
   void init_ss_cost(void) {
     if (no_dynamic && ss_cost == cost_codesize) {
       ss_cost = cost_nexts;
       cost_sums[0] = cost_sums[1]; /* don't use cost_codesize for print-metrics */
       debugp(stderr, "--no-dynamic conflicts with --ss-min-codesize, reverting to --ss-min-nexts\n");
 }  }
   }
   #endif
   
 #if defined(PRINT_SUPER_LENGTHS) && !defined(NO_DYNAMIC)  #define MAX_BB 128 /* maximum number of instructions in BB */
 Cell prim_length(Cell prim)  #define INF_COST 1000000 /* infinite cost */
   #define CANONICAL_STATE 0
   
   struct waypoint {
     int cost;     /* the cost from here to the end */
     PrimNum inst; /* the inst used from here to the next waypoint */
     char relocatable; /* the last non-transition was relocatable */
     char no_transition; /* don't use the next transition (relocatability)
                          * or this transition (does not change state) */
   };
   
   void init_waypoints(struct waypoint ws[])
 {  {
   return priminfos[prim+DOESJUMP+1].length;    int k;
   
     for (k=0; k<maxstates; k++)
       ws[k].cost=INF_COST;
   }
   
   void transitions(struct waypoint inst[], struct waypoint trans[])
   {
     int k;
     struct super_state *l;
   
     for (k=0; k<maxstates; k++) {
       trans[k] = inst[k];
       trans[k].no_transition = 1;
     }
     for (l = state_transitions; l != NULL; l = l->next) {
       PrimNum s = l->super;
       int jcost;
       struct cost *c=super_costs+s;
       struct waypoint *wi=&(trans[c->state_in]);
       struct waypoint *wo=&(inst[c->state_out]);
       if (wo->cost == INF_COST)
         continue;
       jcost = wo->cost + ss_cost(s);
       if (jcost <= wi->cost) {
         wi->cost = jcost;
         wi->inst = s;
         wi->relocatable = wo->relocatable;
         wi->no_transition = 0;
         /* if (ss_greedy) wi->cost = wo->cost ? */
       }
     }
   }
   
   /* use dynamic programming to find the shortest paths within the basic
      block origs[0..ninsts-1] and rewrite the instructions pointed to by
      instps to use it */
   void optimize_rewrite(Cell *instps[], PrimNum origs[], int ninsts)
   {
     int i,j;
     static struct waypoint inst[MAX_BB+1][MAX_STATE];  /* before instruction*/
     static struct waypoint trans[MAX_BB+1][MAX_STATE]; /* before transition */
     int nextdyn, nextstate, no_transition;
   
     init_waypoints(inst[ninsts]);
     inst[ninsts][CANONICAL_STATE].cost=0;
     transitions(inst[ninsts],trans[ninsts]);
     for (i=ninsts-1; i>=0; i--) {
       init_waypoints(inst[i]);
       for (j=1; j<=max_super && i+j<=ninsts; j++) {
         struct super_state **superp = lookup_super(origs+i, j);
         if (superp!=NULL) {
           struct super_state *supers = *superp;
           for (; supers!=NULL; supers = supers->next) {
             PrimNum s = supers->super;
             int jcost;
             struct cost *c=super_costs+s;
             struct waypoint *wi=&(inst[i][c->state_in]);
             struct waypoint *wo=&(trans[i+j][c->state_out]);
             int no_transition = wo->no_transition;
             if (!(is_relocatable(s)) && !wo->relocatable) {
               wo=&(inst[i+j][c->state_out]);
               no_transition=1;
             }
             if (wo->cost == INF_COST)
               continue;
             jcost = wo->cost + ss_cost(s);
             if (jcost <= wi->cost) {
               wi->cost = jcost;
               wi->inst = s;
               wi->relocatable = is_relocatable(s);
               wi->no_transition = no_transition;
               /* if (ss_greedy) wi->cost = wo->cost ? */
             }
           }
         }
       }
       transitions(inst[i],trans[i]);
     }
     /* now rewrite the instructions */
     nextdyn=0;
     nextstate=CANONICAL_STATE;
     no_transition = ((!trans[0][nextstate].relocatable)
                      ||trans[0][nextstate].no_transition);
     for (i=0; i<ninsts; i++) {
       Cell tc=0, tc2;
       if (i==nextdyn) {
         if (!no_transition) {
           /* process trans */
           PrimNum p = trans[i][nextstate].inst;
           struct cost *c = super_costs+p;
           assert(trans[i][nextstate].cost != INF_COST);
           assert(c->state_in==nextstate);
           tc = compile_prim_dyn(p,NULL);
           nextstate = c->state_out;
         }
         {
           /* process inst */
           PrimNum p = inst[i][nextstate].inst;
           struct cost *c=super_costs+p;
           assert(c->state_in==nextstate);
           assert(inst[i][nextstate].cost != INF_COST);
   #if defined(GFORTH_DEBUGGING)
           assert(p == origs[i]);
   #endif
           tc2 = compile_prim_dyn(p,instps[i]);
           if (no_transition || !is_relocatable(p))
             /* !! actually what we care about is if and where
              * compile_prim_dyn() puts NEXTs */
             tc=tc2;
           no_transition = inst[i][nextstate].no_transition;
           nextstate = c->state_out;
           nextdyn += c->length;
 }  }
       } else {
   #if defined(GFORTH_DEBUGGING)
         assert(0);
 #endif  #endif
         tc=0;
         /* tc= (Cell)vm_prims[inst[i][CANONICAL_STATE].inst]; */
       }
       *(instps[i]) = tc;
     }
     if (!no_transition) {
       PrimNum p = trans[i][nextstate].inst;
       struct cost *c = super_costs+p;
       assert(c->state_in==nextstate);
       assert(trans[i][nextstate].cost != INF_COST);
       assert(i==nextdyn);
       (void)compile_prim_dyn(p,NULL);
       nextstate = c->state_out;
     }
     assert(nextstate==CANONICAL_STATE);
   }
   
   /* compile *start, possibly rewriting it into a static and/or dynamic
      superinstruction */
   void compile_prim1(Cell *start)
   {
   #if defined(DOUBLY_INDIRECT)
     Label prim;
   
     if (start==NULL)
       return;
     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(INDIRECT_THREADED)
     return;
   #else /* !(defined(DOUBLY_INDIRECT) || defined(INDIRECT_THREADED)) */
     /* !! does not work, for unknown reasons; but something like this is
        probably needed to ensure that we don't call compile_prim_dyn
        before the inline arguments are there */
     static Cell *instps[MAX_BB];
     static PrimNum origs[MAX_BB];
     static int ninsts=0;
     PrimNum prim_num;
   
     if (start==NULL || ninsts >= MAX_BB ||
         (ninsts>0 && superend[origs[ninsts-1]])) {
       /* after bb, or at the start of the next bb */
       optimize_rewrite(instps,origs,ninsts);
       /* fprintf(stderr,"optimize_rewrite(...,%d)\n",ninsts); */
       ninsts=0;
       if (start==NULL)
         return;
     }
     prim_num = ((Xt)*start)-vm_prims;
     if(prim_num >= npriminfos) {
       optimize_rewrite(instps,origs,ninsts);
       /* fprintf(stderr,"optimize_rewrite(...,%d)\n",ninsts);*/
       ninsts=0;
       return;
     }
     assert(ninsts<MAX_BB);
     instps[ninsts] = start;
     origs[ninsts] = prim_num;
     ninsts++;
   #endif /* !(defined(DOUBLY_INDIRECT) || defined(INDIRECT_THREADED)) */
   }
   
 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 930 
Line 1511 
   
   vm_prims = engine(0,0,0,0,0);    vm_prims = engine(0,0,0,0,0);
   check_prims(vm_prims);    check_prims(vm_prims);
     prepare_super_table();
 #ifndef DOUBLY_INDIRECT  #ifndef DOUBLY_INDIRECT
 #ifdef PRINT_SUPER_LENGTHS  #ifdef PRINT_SUPER_LENGTHS
   print_super_lengths();    print_super_lengths();
Line 974 
Line 1556 
 #elif PAGESIZE  #elif PAGESIZE
   pagesize=PAGESIZE; /* in limits.h according to Gallmeister's POSIX.4 book */    pagesize=PAGESIZE; /* in limits.h according to Gallmeister's POSIX.4 book */
 #endif  #endif
   if (debug)    debugp(stderr,"pagesize=%ld\n",(unsigned long) pagesize);
     fprintf(stderr,"pagesize=%ld\n",(unsigned long) pagesize);  
   
   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);
Line 983 
Line 1564 
   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 1117 
Line 1698 
   return n*m;    return n*m;
 }  }
   
   enum {
     ss_number = 256,
     ss_states,
     ss_min_codesize,
     ss_min_ls,
     ss_min_lsu,
     ss_min_nexts,
   };
   
 void gforth_args(int argc, char ** argv, char ** path, char ** imagename)  void gforth_args(int argc, char ** argv, char ** path, char ** imagename)
 {  {
   int c;    int c;
Line 1141 
Line 1731 
       {"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},
         {"diag", no_argument, &diag, 1},
       {"no-super", no_argument, &no_super, 1},        {"no-super", no_argument, &no_super, 1},
       {"no-dynamic", no_argument, &no_dynamic, 1},        {"no-dynamic", no_argument, &no_dynamic, 1},
       {"dynamic", no_argument, &no_dynamic, 0},        {"dynamic", no_argument, &no_dynamic, 0},
         {"print-metrics", no_argument, &print_metrics, 1},
         {"ss-number", required_argument, NULL, ss_number},
         {"ss-states", required_argument, NULL, ss_states},
   #ifndef NO_DYNAMIC
         {"ss-min-codesize", no_argument, NULL, ss_min_codesize},
   #endif
         {"ss-min-ls",       no_argument, NULL, ss_min_ls},
         {"ss-min-lsu",      no_argument, NULL, ss_min_lsu},
         {"ss-min-nexts",    no_argument, NULL, ss_min_nexts},
         {"ss-greedy",       no_argument, &ss_greedy, 1},
       {0,0,0,0}        {0,0,0,0}
       /* no-init-file, no-rc? */        /* no-init-file, no-rc? */
     };      };
Line 1167 
Line 1768 
     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': fputs(PACKAGE_STRING"\n", stderr); exit(0);      case 'v': fputs(PACKAGE_STRING"\n", stderr); exit(0);
       case ss_number: static_super_number = atoi(optarg); break;
       case ss_states: maxstates = max(min(atoi(optarg),MAX_STATE),1); break;
   #ifndef NO_DYNAMIC
       case ss_min_codesize: ss_cost = cost_codesize; break;
   #endif
       case ss_min_ls:       ss_cost = cost_ls;       break;
       case ss_min_lsu:      ss_cost = cost_lsu;      break;
       case ss_min_nexts:    ss_cost = cost_nexts;    break;
     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 1174 
Line 1783 
   --clear-dictionary                Initialize the dictionary with 0 bytes\n\    --clear-dictionary                Initialize the dictionary with 0 bytes\n\
   -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\
     --diag                            Print diagnostic 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\    --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\
Line 1186 
Line 1796 
   --no-super                        No dynamically formed superinstructions\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\
     --print-metrics                   Print some code generation metrics on exit\n\
   -r SIZE, --return-stack-size=SIZE Specify return stack size\n\    -r SIZE, --return-stack-size=SIZE Specify return stack size\n\
     --ss-greedy                       greedy, not optimal superinst selection\n\
     --ss-min-codesize                 select superinsts for smallest native code\n\
     --ss-min-ls                       minimize loads and stores\n\
     --ss-min-lsu                      minimize loads, stores, and pointer updates\n\
     --ss-min-nexts                    minimize the number of static superinsts\n\
     --ss-number=N                     use N static superinsts (default max)\n\
     --ss-states=N                     N states for stack caching (default max)\n\
   -v, --version                     Print engine 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",
Line 1198 
Line 1816 
 }  }
 #endif  #endif
   
 #ifdef INCLUDE_IMAGE  void print_diag()
 extern Cell image[];  
 extern const char reloc_bits[];  
 #endif  
   
 DCell double2ll(Float r)  
 {  {
 #ifndef BUGGY_LONG_LONG  
   return (DCell)(r);  #if !defined(HAVE_GETRUSAGE) || !defined(HAS_FFCALL)
     fprintf(stderr, "*** missing functionality ***\n"
   #ifndef HAVE_GETRUSAGE
             "    no getrusage -> CPUTIME broken\n"
   #endif
   #ifndef HAS_FFCALL
             "    no ffcall -> only old-style foreign function calls (no fflib.fs)\n"
   #endif
             );
   #endif
     if((relocs < nonrelocs) ||
   #if defined(BUGGY_LL_CMP) || defined(BUGGY_LL_MUL) || defined(BUGGY_LL_DIV) || defined(BUGGY_LL_ADD) || defined(BUGGY_LL_SHIFT) || defined(BUGGY_LL_D2F) || defined(BUGGY_LL_F2D)
        1
 #else  #else
   DCell d;       0
   d.hi = ldexp(r,-(int)(CELL_BITS)) - (r<0);  #endif
   d.lo = r-ldexp((Float)d.hi,CELL_BITS);       )
   return d;      debugp(stderr, "relocs: %d:%d\n", relocs, nonrelocs);
       fprintf(stderr, "*** performance problems ***\n%s"
   #if defined(BUGGY_LL_CMP) || defined(BUGGY_LL_MUL) || defined(BUGGY_LL_DIV) || defined(BUGGY_LL_ADD) || defined(BUGGY_LL_SHIFT) || defined(BUGGY_LL_D2F) || defined(BUGGY_LL_F2D)
               "    double-cell integer type buggy ->\n        "
   #ifdef BUGGY_LL_CMP
               "CMP, "
   #endif
   #ifdef BUGGY_LL_MUL
               "MUL, "
   #endif
   #ifdef BUGGY_LL_DIV
               "DIV, "
   #endif
   #ifdef BUGGY_LL_ADD
               "ADD, "
 #endif  #endif
   #ifdef BUGGY_LL_SHIFT
               "SHIFT, "
   #endif
   #ifdef BUGGY_LL_D2F
               "D2F, "
   #endif
   #ifdef BUGGY_LL_F2D
               "F2D, "
   #endif
               "\b\b slow\n"
   #endif
   #ifndef FORCE_REG
               "    automatic register allocation: performance degradation possible\n"
   #endif
   #if !defined(FORCE_REG) || defined(BUGGY_LONG_LONG)
               "*** Suggested remedy: try ./configure"
   #ifndef FORCE_REG
               " --enable-force-reg"
   #endif
   #ifdef BUGGY_LONG_LONG
               " --enable-force-ll"
   #endif
               "\n"
   #endif
               ,
               (relocs < nonrelocs) ? "    gcc PR 15242 -> no dynamic code generation (use gcc-2.95 instead)\n" : "");
 }  }
   
   #ifdef INCLUDE_IMAGE
   extern Cell image[];
   extern const char reloc_bits[];
   #endif
   
 int main(int argc, char **argv, char **env)  int main(int argc, char **argv, char **env)
 {  {
 #ifdef HAS_OS  #ifdef HAS_OS
Line 1251 
Line 1921 
   
 #ifdef HAS_OS  #ifdef HAS_OS
   gforth_args(argc, argv, &path, &imagename);    gforth_args(argc, argv, &path, &imagename);
 #endif  #ifndef NO_DYNAMIC
     init_ss_cost();
   #endif /* !defined(NO_DYNAMIC) */
   #endif /* defined(HAS_OS) */
   
 #ifdef INCLUDE_IMAGE  #ifdef INCLUDE_IMAGE
   set_stack_sizes((ImageHeader *)image);    set_stack_sizes((ImageHeader *)image);
Line 1265 
Line 1938 
 #endif  #endif
   gforth_header=(ImageHeader *)image; /* used in SIGSEGV handler */    gforth_header=(ImageHeader *)image; /* used in SIGSEGV handler */
   
     if (diag)
       print_diag();
   {    {
     char path2[strlen(path)+1];      char path2[strlen(path)+1];
     char *p1, *p2;      char *p1, *p2;
Line 1286 
Line 1961 
         *p2 = *p1;          *p2 = *p1;
     *p2='\0';      *p2='\0';
     retvalue = go_forth(image, 4, environ);      retvalue = go_forth(image, 4, environ);
   #ifdef SIGPIPE
       bsd_signal(SIGPIPE, SIG_IGN);
   #endif
 #ifdef VM_PROFILING  #ifdef VM_PROFILING
     vm_print_profile(stderr);      vm_print_profile(stderr);
 #endif  #endif
     deprep_terminal();      deprep_terminal();
   }    }
     if (print_metrics) {
       int i;
       fprintf(stderr, "code size = %8ld\n", dyncodesize());
       for (i=0; i<sizeof(cost_sums)/sizeof(cost_sums[0]); i++)
         fprintf(stderr, "metric %8s: %8ld\n",
                 cost_sums[i].metricname, cost_sums[i].sum);
     }
   return retvalue;    return retvalue;
 }  }

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help