[gforth] / gforth / engine / main.c  

gforth: gforth/engine/main.c

Diff for /gforth/engine/main.c between version 1.120 and 1.207

version 1.120, Sat Aug 16 21:09:47 2003 UTC version 1.207, Thu Jul 3 12:29:05 2008 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,2003 Free Software Foundation, Inc.    Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006,2007 Free Software Foundation, Inc.
   
   This file is part of Gforth.    This file is part of Gforth.
   
   Gforth is free software; you can redistribute it and/or    Gforth is free software; you can redistribute it and/or
   modify it under the terms of the GNU General Public License    modify it under the terms of the GNU General Public License
   as published by the Free Software Foundation; either version 2    as published by the Free Software Foundation, either version 3
   of the License, or (at your option) any later version.    of the License, or (at your option) any later version.
   
   This program is distributed in the hope that it will be useful,    This program is distributed in the hope that it will be useful,
Line 16 
Line 16 
   GNU General Public License for more details.    GNU General Public License for more details.
   
   You should have received a copy of the GNU General Public License    You should have received a copy of the GNU General Public License
   along with this program; if not, write to the Free Software    along with this program; if not, see http://www.gnu.org/licenses/.
   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.  
 */  */
   
 #include "config.h"  #include "config.h"
Line 35 
Line 34 
 #include <fcntl.h>  #include <fcntl.h>
 #include <assert.h>  #include <assert.h>
 #include <stdlib.h>  #include <stdlib.h>
   #include <stdbool.h>
 #include <signal.h>  #include <signal.h>
 #ifndef STANDALONE  #ifndef STANDALONE
 #if HAVE_SYS_MMAN_H  #if HAVE_SYS_MMAN_H
Line 44 
Line 44 
 #include "io.h"  #include "io.h"
 #include "getopt.h"  #include "getopt.h"
 #ifdef STANDALONE  #ifdef STANDALONE
 #include <systypes.h>  /* #include <systypes.h> */
 #endif  #endif
   
 enum {  /* output rules etc. for burg with --debug and --print-sequences */
   /* #define BURG_FORMAT*/
   
   typedef enum prim_num {
 /* definitions of N_execute etc. */  /* definitions of N_execute etc. */
 #include "prim_num.i"  #include PRIM_NUM_I
   N_START_SUPER    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. */
 Cell *SP;  Cell *gforth_SP;
 Float *FP;  Float *gforth_FP;
 Address UP=NULL;  Address gforth_UP=NULL;
   Cell *gforth_RP;
   Address gforth_LP;
   
 #ifdef HAS_FFCALL  #ifdef HAS_FFCALL
 Cell *RP;  
 Address LP;  
   
 #include <callback.h>  #include <callback.h>
   
 va_alist clist;  va_alist gforth_clist;
   
 void engine_callback(Xt* fcall, void * alist)  void gforth_callback(Xt* fcall, void * alist)
 {  {
   clist = (va_alist)alist;    /* save global valiables */
   engine(fcall, SP, RP, FP, LP);    Cell *rp = gforth_RP;
     Cell *sp = gforth_SP;
     Float *fp = gforth_FP;
     Address lp = gforth_LP;
     va_alist clist = gforth_clist;
   
     gforth_clist = (va_alist)alist;
   
     gforth_engine(fcall, sp, rp, fp, lp sr_call);
   
     /* restore global variables */
     gforth_RP = rp;
     gforth_SP = sp;
     gforth_FP = fp;
     gforth_LP = lp;
     gforth_clist = clist;
 }  }
 #endif  #endif
   
Line 79 
Line 97 
 /* 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
    GNU C manual) */     GNU C manual) */
   #if defined(GLOBALS_NONRELOC)
   saved_regs saved_regs_v;
   saved_regs *saved_regs_p = &saved_regs_v;
   #else /* !defined(GLOBALS_NONRELOC) */
 Xt *saved_ip;  Xt *saved_ip;
 Cell *rp;  Cell *rp;
 #endif  #endif /* !defined(GLOBALS_NONRELOC) */
   #endif /* !defined(GFORTH_DEBUGGING) */
   
 #ifdef NO_IP  #ifdef NO_IP
 Label next_code;  Label next_code;
Line 131 
Line 154 
 static UCell lsize=0;  static UCell lsize=0;
 int offset_image=0;  int offset_image=0;
 int die_on_signal=0;  int die_on_signal=0;
   int ignore_async_signals=0;
 #ifndef INCLUDE_IMAGE  #ifndef INCLUDE_IMAGE
 static int clear_dictionary=0;  static int clear_dictionary=0;
 UCell pagesize=1;  UCell pagesize=1;
Line 139 
Line 163 
 char *progname = "gforth";  char *progname = "gforth";
 int optind = 1;  int optind = 1;
 #endif  #endif
   #ifndef MAP_NORESERVE
   #define MAP_NORESERVE 0
   #endif
   /* IF you have an old Cygwin, this may help:
   #ifdef __CYGWIN__
   #define MAP_NORESERVE 0
   #endif
   */
   static int map_noreserve=MAP_NORESERVE;
   
 #define CODE_BLOCK_SIZE (256*1024)  #define CODE_BLOCK_SIZE (512*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
Line 153 
Line 186 
 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 print_metrics=0; /* if true, print metrics on exit */
 static int static_super_number = 10000000; /* number of ss used if available */  static int static_super_number = 10000; /* number of ss used if available */
   #define MAX_STATE 9 /* 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 ss_greedy = 0; /* if true: use greedy, not optimal ss selection */
   static int diag = 0; /* if true: print diagnostic informations */
   static int tpa_noequiv = 0;     /* if true: no state equivalence checking */
   static int tpa_noautomaton = 0; /* if true: no tree parsing automaton */
   static int tpa_trace = 0; /* if true: data for line graph of new states etc. */
   static int print_sequences = 0; /* print primitive sequences for optimization */
   static int relocs = 0;
   static int nonrelocs = 0;
   
 #ifdef HAS_DEBUG  #ifdef HAS_DEBUG
 int debug=0;  int debug=0;
   # define debugp(x...) do { if (debug) fprintf(x); } while (0)
 #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 169 
Line 213 
 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
   #ifndef CODE_ALIGNMENT
   #define CODE_ALIGNMENT 0
   #endif
   
   #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 176 
Line 260 
 }  }
 #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;
   }
   
   #ifndef STANDALONE
 /* 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 209 
Line 304 
   
 Cell groups[32] = {  Cell groups[32] = {
   0,    0,
 DOESJUMP+1    0
 #undef GROUP  #undef GROUP
 #undef GROUPADD  #undef GROUPADD
 #define GROUPADD(n) +n  #define GROUPADD(n) +n
 #define GROUP(x, n) , 0  #define GROUP(x, n) , 0
 #include "prim_grp.i"  #include PRIM_GRP_I
 #undef GROUP  #undef GROUP
 #undef GROUPADD  #undef GROUPADD
 #define GROUP(x, n)  #define GROUP(x, n)
 #define GROUPADD(n)  #define GROUPADD(n)
 };  };
   
 void relocate(Cell *image, const unsigned char *bitstring,  static unsigned char *branch_targets(Cell *image, const unsigned char *bitstring,
               int size, Cell base, Label symbols[])                                int size, Cell base)
        /* produce a bitmask marking all the branch targets */
 {  {
   int i=0, j, k, steps=(size/sizeof(Cell))/RELINFOBITS;    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);
             if (bitnum/RELINFOBITS < (UCell)steps)
               result[bitnum/RELINFOBITS] |= 1U << ((~bitnum)&(RELINFOBITS-1));
           }
         }
       }
     }
     return result;
   }
   
   void gforth_relocate(Cell *image, const Char *bitstring,
                        UCell size, Cell base, Label symbols[])
   {
     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;
Line 233 
Line 354 
    * 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 */    /* group index into table */
   if(groups[31]==0) {    if(groups[31]==0) {
Line 247 
Line 369 
   
 /* 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) {
Line 267 
Line 389 
             case CF(DOCOL)   :              case CF(DOCOL)   :
             case CF(DOVAR)   :              case CF(DOVAR)   :
             case CF(DOCON)   :              case CF(DOCON)   :
               case CF(DOVAL)   :
             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;
Line 281 
Line 404 
               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 %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);                  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);
Line 296 
Line 422 
               image[i]=(Cell)CFA((groups[group]+tok));                image[i]=(Cell)CFA((groups[group]+tok));
 #endif  #endif
 #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 %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);                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);
Line 311 
Line 440 
       }        }
     }      }
   }    }
     free(targets);
   finish_code();    finish_code();
   ((ImageHeader*)(image))->base = (Address) image;    ((ImageHeader*)(image))->base = (Address) image;
 }  }
   
 UCell checksum(Label symbols[])  #ifndef DOUBLY_INDIRECT
   static UCell checksum(Label symbols[])
 {  {
   UCell r=PRIM_VERSION;    UCell r=PRIM_VERSION;
   Cell i;    Cell i;
Line 338 
Line 469 
 #endif  #endif
   return r;    return r;
 }  }
   #endif
   
 Address verbose_malloc(Cell size)  static Address verbose_malloc(Cell size)
 {  {
   Address r;    Address r;
   /* leave a little room (64B) for stack underflows */    /* leave a little room (64B) for stack underflows */
Line 348 
Line 480 
     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;
 }  }
   
 static Address next_address=0;  static Address next_address=0;
 void after_alloc(Address r, Cell size)  static 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 0
       /* not needed now that we protect the stacks with mprotect */
     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 */
   #endif
   } else {    } else {
     if (debug)      debugp(stderr, "failed: %s\n", strerror(errno));
       fprintf(stderr, "failed: %s\n", strerror(errno));  
   }    }
 }  }
   
Line 386 
Line 518 
   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|map_noreserve, -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
      apparently defaults) */       apparently defaults) */
Line 398 
Line 529 
     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|map_noreserve, 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) */
   after_alloc(r, size);    after_alloc(r, size);
   return r;    return r;
 }  }
   
   static void page_noaccess(Address a)
   {
     /* try mprotect first; with munmap the page might be allocated later */
     debugp(stderr, "try mprotect(%p,%ld,PROT_NONE); ", a, (long)pagesize);
     if (mprotect(a, pagesize, PROT_NONE)==0) {
       debugp(stderr, "ok\n");
       return;
     }
     debugp(stderr, "failed: %s\n", strerror(errno));
     debugp(stderr, "try munmap(%p,%ld); ", a, (long)pagesize);
     if (munmap(a,pagesize)==0) {
       debugp(stderr, "ok\n");
       return;
     }
     debugp(stderr, "failed: %s\n", strerror(errno));
   }
   
   static size_t wholepage(size_t n)
   {
     return (n+pagesize-1)&~(pagesize-1);
   }
 #endif  #endif
   
 Address my_alloc(Cell size)  Address gforth_alloc(Cell size)
 {  {
 #if HAVE_MMAP  #if HAVE_MMAP
   Address r;    Address r;
Line 425 
Line 576 
   return verbose_malloc(size);    return verbose_malloc(size);
 }  }
   
 Address dict_alloc_read(FILE *file, Cell imagesize, Cell dictsize, Cell offset)  static Address dict_alloc_read(FILE *file, Cell imagesize, Cell dictsize, Cell offset)
 {  {
   Address image = MAP_FAILED;    Address image = MAP_FAILED;
   
 #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|map_noreserve, 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 == (Address)MAP_FAILED) {    if (image == (Address)MAP_FAILED) {
     image = my_alloc(dictsize+offset)+offset;      image = gforth_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);
   }    }
   return image;    return image;
 }  }
   #endif
   
 void set_stack_sizes(ImageHeader * header)  void set_stack_sizes(ImageHeader * header)
 {  {
Line 465 
Line 622 
   fsize=maxaligned(fsize);    fsize=maxaligned(fsize);
 }  }
   
 void alloc_stacks(ImageHeader * header)  #ifdef STANDALONE
   void alloc_stacks(ImageHeader * h)
   {
   #define SSTACKSIZE 0x200
     static Cell dstack[SSTACKSIZE+1];
     static Cell rstack[SSTACKSIZE+1];
   
     h->dict_size=dictsize;
     h->data_stack_size=dsize;
     h->fp_stack_size=fsize;
     h->return_stack_size=rsize;
     h->locals_stack_size=lsize;
   
     h->data_stack_base=dstack+SSTACKSIZE;
     //  h->fp_stack_base=gforth_alloc(fsize);
     h->return_stack_base=rstack+SSTACKSIZE;
     //  h->locals_stack_base=gforth_alloc(lsize);
   }
   #else
   void alloc_stacks(ImageHeader * h)
 {  {
   header->dict_size=dictsize;    h->dict_size=dictsize;
   header->data_stack_size=dsize;    h->data_stack_size=dsize;
   header->fp_stack_size=fsize;    h->fp_stack_size=fsize;
   header->return_stack_size=rsize;    h->return_stack_size=rsize;
   header->locals_stack_size=lsize;    h->locals_stack_size=lsize;
   
   header->data_stack_base=my_alloc(dsize);  #if defined(HAVE_MMAP) && !defined(STANDALONE)
   header->fp_stack_base=my_alloc(fsize);    if (pagesize > 1) {
   header->return_stack_base=my_alloc(rsize);      size_t p = pagesize;
   header->locals_stack_base=my_alloc(lsize);      size_t totalsize =
         wholepage(dsize)+wholepage(fsize)+wholepage(rsize)+wholepage(lsize)+5*p;
       Address a = alloc_mmap(totalsize);
       if (a != (Address)MAP_FAILED) {
         page_noaccess(a); a+=p; h->  data_stack_base=a; a+=wholepage(dsize);
         page_noaccess(a); a+=p; h->    fp_stack_base=a; a+=wholepage(fsize);
         page_noaccess(a); a+=p; h->return_stack_base=a; a+=wholepage(rsize);
         page_noaccess(a); a+=p; h->locals_stack_base=a; a+=wholepage(lsize);
         page_noaccess(a);
         debugp(stderr,"stack addresses: d=%p f=%p r=%p l=%p\n",
                h->data_stack_base,
                h->fp_stack_base,
                h->return_stack_base,
                h->locals_stack_base);
         return;
       }
     }
   #endif
     h->data_stack_base=gforth_alloc(dsize);
     h->fp_stack_base=gforth_alloc(fsize);
     h->return_stack_base=gforth_alloc(rsize);
     h->locals_stack_base=gforth_alloc(lsize);
 }  }
   #endif
   
 #warning You can ignore the warnings about clobbered variables in go_forth  #warning You can ignore the warnings about clobbered variables in gforth_go
 int go_forth(Address image, int stack, Cell *entries)  int gforth_go(Address image, int stack, Cell *entries)
 {  {
   volatile ImageHeader *image_header = (ImageHeader *)image;    volatile ImageHeader *image_header = (ImageHeader *)image;
   Cell *sp0=(Cell*)(image_header->data_stack_base + dsize);    Cell *sp0=(Cell*)(image_header->data_stack_base + dsize);
Line 496 
Line 694 
 #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))
   IF_fpTOS(fp0--);    sp0 -= 8; /* make stuff below bottom accessible for stack caching */
     fp0--;
   #endif
   
   for(;stack>0;stack--)    for(;stack>0;stack--)
     *--sp0=entries[stack-1];      *--sp0=entries[stack-1];
   
 #ifdef SYSSIGNALS  #if defined(SYSSIGNALS) && !defined(STANDALONE)
   get_winsize();    get_winsize();
   
   install_signal_handlers(); /* right place? */    install_signal_handlers(); /* right place? */
   
   if ((throw_code=setjmp(throw_jmp_buf))) {    if ((throw_code=setjmp(throw_jmp_buf))) {
     static Cell signal_data_stack[8];      static Cell signal_data_stack[24];
     static Cell signal_return_stack[8];      static Cell signal_return_stack[16];
     static Float signal_fp_stack[1];      static Float signal_fp_stack[1];
   
     signal_data_stack[7]=throw_code;      signal_data_stack[15]=throw_code;
   
 #ifdef GFORTH_DEBUGGING  #ifdef GFORTH_DEBUGGING
     if (debug)      debugp(stderr,"\ncaught signal, throwing exception %d, ip=%p rp=%p\n",
       fprintf(stderr,"\ncaught signal, throwing exception %d, ip=%p rp=%p\n",  
               throw_code, saved_ip, rp);                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 */
Line 524 
Line 723 
       *--rp0 = (Cell)saved_ip;        *--rp0 = (Cell)saved_ip;
     }      }
     else /* I love non-syntactic ifdefs :-) */      else /* I love non-syntactic ifdefs :-) */
       rp0 = signal_return_stack+8;        rp0 = signal_return_stack+16;
 #else  /* !defined(GFORTH_DEBUGGING) */  #else  /* !defined(GFORTH_DEBUGGING) */
     if (debug)      debugp(stderr,"\ncaught signal, throwing exception %d\n", throw_code);
       fprintf(stderr,"\ncaught signal, throwing exception %d\n", throw_code);        rp0 = signal_return_stack+16;
       rp0 = signal_return_stack+8;  
 #endif /* !defined(GFORTH_DEBUGGING) */  #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)gforth_engine(image_header->throw_entry, signal_data_stack+15,
                        rp0, signal_fp_stack, 0));                         rp0, signal_fp_stack, 0 sr_call));
   }    }
 #endif  #endif
   
   return((int)(Cell)engine(ip0,sp0,rp0,fp0,lp0));    return((int)(Cell)gforth_engine(ip0,sp0,rp0,fp0,lp0 sr_call));
 }  }
   
 #ifndef INCLUDE_IMAGE  #if !defined(INCLUDE_IMAGE) && !defined(STANDALONE)
 void print_sizes(Cell sizebyte)  static void print_sizes(Cell sizebyte)
      /* print size information */       /* print size information */
 {  {
   static char* endianstring[]= { "   big","little" };    static char* endianstring[]= { "   big","little" };
Line 555 
Line 753 
   
 /* static superinstruction stuff */  /* static superinstruction stuff */
   
 struct cost {  struct cost { /* super_info might be a more accurate name */
   char loads;       /* number of stack loads */    char loads;       /* number of stack loads */
   char stores;      /* number of stack stores */    char stores;      /* number of stack stores */
   char updates;     /* number of stack pointer updates */    char updates;     /* number of stack pointer updates */
     char branch;      /* is it a branch (SET_IP) */
     unsigned char state_in;    /* state on entry */
     unsigned char state_out;   /* state on exit */
     unsigned char imm_ops;     /* number of immediate operands */
   short offset;      /* offset into super2 table */    short offset;      /* offset into super2 table */
   char length;      /* number of components */    unsigned char length;      /* number of components */
 };  };
   
 short super2[] = {  PrimNum super2[] = {
 #include "super2.i"  #include SUPER2_I
 };  };
   
 struct cost super_costs[] = {  struct cost super_costs[] = {
 #include "costs.i"  #include COSTS_I
   };
   
   struct super_state {
     struct super_state *next;
     PrimNum super;
 };  };
   
 #define HASH_SIZE 256  #define HASH_SIZE 256
   
 struct super_table_entry {  struct super_table_entry {
   struct super_table_entry *next;    struct super_table_entry *next;
   short *start;    PrimNum *start;
   short length;    short length;
   short super;    struct super_state *ss_list; /* list of supers */
 } *super_table[HASH_SIZE];  } *super_table[HASH_SIZE];
 int max_super=2;  int max_super=2;
   
 int hash_super(short *start, int length)  struct super_state *state_transitions=NULL;
   
   static int hash_super(PrimNum *start, int length)
 {  {
   int i, r;    int i, r;
   
Line 592 
Line 801 
   return r & (HASH_SIZE-1);    return r & (HASH_SIZE-1);
 }  }
   
 int lookup_super(short *start, int length)  static struct super_state **lookup_super(PrimNum *start, int length)
 {  {
   int hash=hash_super(start,length);    int hash=hash_super(start,length);
   struct super_table_entry *p = super_table[hash];    struct super_table_entry *p = super_table[hash];
   
   assert(length >= 2);    /* assert(length >= 2); */
   for (; p!=NULL; p = p->next) {    for (; p!=NULL; p = p->next) {
     if (length == p->length &&      if (length == p->length &&
         memcmp((char *)p->start, (char *)start, length*sizeof(short))==0)          memcmp((char *)p->start, (char *)start, length*sizeof(PrimNum))==0)
       return p->super;        return &(p->ss_list);
   }    }
   return -1;    return NULL;
 }  }
   
 void prepare_super_table()  static void prepare_super_table()
 {  {
   int i;    int i;
   int nsupers = 0;    int nsupers = 0;
   
   for (i=0; i<sizeof(super_costs)/sizeof(super_costs[0]); i++) {    for (i=0; i<sizeof(super_costs)/sizeof(super_costs[0]); i++) {
     struct cost *c = &super_costs[i];      struct cost *c = &super_costs[i];
     if (c->length > 1 && nsupers < static_super_number) {      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);        int hash = hash_super(super2+c->offset, c->length);
       struct super_table_entry **p = &super_table[hash];        struct super_table_entry **p = &super_table[hash];
       struct super_table_entry *e = malloc(sizeof(struct super_table_entry));        struct super_table_entry *e = malloc(sizeof(struct super_table_entry));
           ss->next = NULL;
       e->next = *p;        e->next = *p;
       e->start = super2 + c->offset;        e->start = super2 + c->offset;
       e->length = c->length;        e->length = c->length;
       e->super = i;          e->ss_list = ss;
       *p = e;        *p = e;
         }
       if (c->length > max_super)        if (c->length > max_super)
         max_super = c->length;          max_super = c->length;
         if (c->length >= 2)
       nsupers++;        nsupers++;
     }      }
   }    }
   if (debug)    debugp(stderr, "Using %d static superinsts\n", nsupers);
     fprintf(stderr, "Using %d static superinsts\n", nsupers);    if (nsupers>0 && !tpa_noautomaton && !tpa_noequiv) {
       /* Currently these two things don't work together; see Section 3.2
          of <http://www.complang.tuwien.ac.at/papers/ertl+06pldi.ps.gz>,
          in particular Footnote 6 for the reason; hmm, we should be able
          to use an automaton without state equivalence, but that costs
          significant space so we only do it if the user explicitly
          disables state equivalence. */
       debugp(stderr, "Disabling tpa-automaton, because nsupers>0 and state equivalence is enabled.\n");
       tpa_noautomaton = true;
     }
 }  }
   
 /* dynamic replication/superinstruction stuff */  /* dynamic replication/superinstruction stuff */
   
 #define MAX_IMMARGS 2  
   
 #ifndef NO_DYNAMIC  #ifndef NO_DYNAMIC
 typedef struct {  static int compare_priminfo_length(const void *_a, const void *_b)
   Label start;  
   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;  
   
 int compare_priminfo_length(const void *_a, const void *_b)  
 {  {
   PrimInfo **a = (PrimInfo **)_a;    PrimInfo **a = (PrimInfo **)_a;
   PrimInfo **b = (PrimInfo **)_b;    PrimInfo **b = (PrimInfo **)_b;
Line 666 
Line 882 
 }  }
 #endif /* !defined(NO_DYNAMIC) */  #endif /* !defined(NO_DYNAMIC) */
   
 static char superend[]={  static char MAYBE_UNUSED superend[]={
 #include "prim_superend.i"  #include PRIM_SUPEREND_I
 };  };
   
 Cell npriminfos=0;  Cell npriminfos=0;
   
 int compare_labels(const void *pa, const void *pb)  Label goto_start;
   Cell goto_len;
   
   #ifndef NO_DYNAMIC
   static int compare_labels(const void *pa, const void *pb)
 {  {
   Label a = *(Label *)pa;    Label a = *(Label *)pa;
   Label b = *(Label *)pb;    Label b = *(Label *)pb;
   return a-b;    return a-b;
 }  }
   #endif
   
 Label bsearch_next(Label key, Label *a, UCell n)  static Label bsearch_next(Label key, Label *a, UCell n)
      /* a is sorted; return the label >=key that is the closest in a;       /* a is sorted; return the label >=key that is the closest in a;
         return NULL if there is no label in a >=key */          return NULL if there is no label in a >=key */
 {  {
Line 698 
Line 919 
     return bsearch_next(key, a, mid+1);      return bsearch_next(key, a, mid+1);
 }  }
   
 void check_prims(Label symbols1[])  static void check_prims(Label symbols1[])
 {  {
   int i;    int i;
 #ifndef NO_DYNAMIC  #ifndef NO_DYNAMIC
   Label *symbols2, *symbols3, *ends1, *ends1j, *ends1jsorted;    Label *symbols2, *symbols3, *ends1, *ends1j, *ends1jsorted, *goto_p;
   int nends1j;    int nends1j;
 #endif  #endif
   
Line 714 
Line 935 
 #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;
   
 #ifndef NO_DYNAMIC  #ifndef NO_DYNAMIC
   if (no_dynamic)    if (no_dynamic)
     return;      return;
   symbols2=engine2(0,0,0,0,0);    symbols2=gforth_engine2(0,0,0,0,0 sr_call);
 #if NO_IP  #if NO_IP
   symbols3=engine3(0,0,0,0,0);    symbols3=gforth_engine3(0,0,0,0,0 sr_call);
 #else  #else
   symbols3=symbols1;    symbols3=symbols1;
 #endif  #endif
   ends1 = symbols1+i+1-DOESJUMP;    ends1 = symbols1+i+1;
   ends1j =   ends1+i;    ends1j =   ends1+i;
   nends1j = i-DOESJUMP;    goto_p = ends1j+i+1; /* goto_p[0]==before; ...[1]==after;*/
     nends1j = i+1;
   ends1jsorted = (Label *)alloca(nends1j*sizeof(Label));    ends1jsorted = (Label *)alloca(nends1j*sizeof(Label));
   memcpy(ends1jsorted,ends1j,nends1j*sizeof(Label));    memcpy(ends1jsorted,ends1j,nends1j*sizeof(Label));
   qsort(ends1jsorted, nends1j, sizeof(Label), compare_labels);    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],(long)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];
       struct cost *sc=&super_costs[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];
Line 745 
Line 980 
     Label endlabel = bsearch_next(symbols1[i]+1,ends1jsorted,nends1j);      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 = endlabel-symbols1[i];  
     else  
       pi->length = prim_len;        pi->length = prim_len;
     pi->restlength = endlabel - 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=%3ld restlength=%2ld superend=%1d",  #if defined(BURG_FORMAT)
               i, s1, s2, s3, (long)(pi->length), (long)(pi->restlength), pi->superend);      { /* output as burg-style rules */
         int p=super_costs[i].offset;
         if (p==N_noop)
           debugp(stderr, "S%d: S%d = %d (%d);", sc->state_in, sc->state_out, i+1, pi->length);
         else
           debugp(stderr, "S%d: op%d(S%d) = %d (%d);", sc->state_in, p, sc->state_out, i+1, pi->length);
       }
   #else
       debugp(stderr, "%-15s %d-%d %4d %p %p %p len=%3ld rest=%2ld send=%1d",
              prim_names[i], sc->state_in, sc->state_out,
              i, s1, s2, s3, (long)(pi->length), (long)(pi->restlength),
              pi->superend);
   #endif
     if (endlabel == NULL) {      if (endlabel == NULL) {
       pi->start = NULL; /* not relocatable */        pi->start = NULL; /* not relocatable */
       if (debug)        if (pi->length<0) pi->length=100;
         fprintf(stderr,"\n   non_reloc: no J label > start found\n");  #ifndef BURG_FORMAT
         debugp(stderr,"\n   non_reloc: no J label > start found\n");
   #endif
         relocs--;
         nonrelocs++;
       continue;        continue;
     }      }
     if (ends1[i] > endlabel && !pi->superend) {      if (ends1[i] > endlabel && !pi->superend) {
       pi->start = NULL; /* not relocatable */        pi->start = NULL; /* not relocatable */
       if (debug)        pi->length = endlabel-symbols1[i];
         fprintf(stderr,"\n   non_reloc: there is a J label before the J label (restlength<0)\n");  #ifndef BURG_FORMAT
         debugp(stderr,"\n   non_reloc: there is a J label before the K label (restlength<0)\n");
   #endif
         relocs--;
         nonrelocs++;
       continue;        continue;
     }      }
     if (ends1[i] < pi->start && !pi->superend) {      if (ends1[i] < pi->start && !pi->superend) {
       pi->start = NULL; /* not relocatable */        pi->start = NULL; /* not relocatable */
       if (debug)        pi->length = endlabel-symbols1[i];
         fprintf(stderr,"\n   non_reloc: K label before I label (length<0)\n");  #ifndef BURG_FORMAT
         debugp(stderr,"\n   non_reloc: K label before I label (length<0)\n");
   #endif
         relocs--;
         nonrelocs++;
       continue;        continue;
     }      }
     assert(prim_len>=0);      assert(pi->length>=0);
     assert(pi->restlength >=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)  #ifndef BURG_FORMAT
             fprintf(stderr,"\n   non_reloc: engine1!=engine2 offset %3d",j);            debugp(stderr,"\n   non_reloc: engine1!=engine2 offset %3d",j);
   #endif
           /* assert(j<prim_len); */            /* assert(j<prim_len); */
             relocs--;
             nonrelocs++;
           break;            break;
         }          }
         j++;          j++;
Line 792 
Line 1051 
         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)  #ifndef BURG_FORMAT
             fprintf(stderr,"\n   non_reloc: engine1!=engine3 offset %3d",j);            debugp(stderr,"\n   non_reloc: engine1!=engine3 offset %3d",j);
   #endif
           /* 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 820 
Line 1079 
 #endif  #endif
 }  }
   
 void flush_to_here(void)  static void flush_to_here(void)
 {  {
 #ifndef NO_DYNAMIC  #ifndef NO_DYNAMIC
   if (start_flush)    if (start_flush)
Line 829 
Line 1088 
 #endif  #endif
 }  }
   
   static void align_code(void)
        /* align code_here on some platforms */
   {
   #ifndef NO_DYNAMIC
   #if defined(CODE_PADDING)
     Cell alignment = CODE_ALIGNMENT;
     static char nops[] = CODE_PADDING;
     UCell maxpadding=MAX_PADDING;
     UCell offset = ((UCell)code_here)&(alignment-1);
     UCell length = alignment-offset;
     if (length <= maxpadding) {
       memcpy(code_here,nops+offset,length);
       code_here += length;
     }
   #endif /* defined(CODE_PADDING) */
   #endif /* defined(NO_DYNAMIC */
   }
   
 #ifndef NO_DYNAMIC  #ifndef NO_DYNAMIC
 void append_jump(void)  static void append_jump(void)
 {  {
   if (last_jump) {    if (last_jump) {
     PrimInfo *pi = &priminfos[last_jump];      PrimInfo *pi = &priminfos[last_jump];
   
     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;
       align_code();
     last_jump=0;      last_jump=0;
   }    }
 }  }
Line 854 
Line 1134 
   Cell size;    Cell size;
 } *code_block_list=NULL, **next_code_blockp=&code_block_list;  } *code_block_list=NULL, **next_code_blockp=&code_block_list;
   
 Address append_prim(Cell p)  static Address append_prim(Cell p)
 {  {
   PrimInfo *pi = &priminfos[p];    PrimInfo *pi = &priminfos[p];
   Address old_code_here = code_here;    Address old_code_here = code_here;
   
   if (code_area+code_area_size < code_here+pi->length+pi->restlength) {    if (code_area+code_area_size < code_here+pi->length+pi->restlength+goto_len+CODE_ALIGNMENT) {
     struct code_block_list *p;      struct code_block_list *p;
     append_jump();      append_jump();
     flush_to_here();      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 = gforth_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));
       *next_code_blockp = p;        *next_code_blockp = p;
       p->next = NULL;        p->next = NULL;
Line 903 
Line 1183 
 #endif /* !defined(NO_DYNAMIC) */  #endif /* !defined(NO_DYNAMIC) */
 }  }
   
 long dyncodesize(void)  static long dyncodesize(void)
 {  {
 #ifndef NO_DYNAMIC  #ifndef NO_DYNAMIC
   struct code_block_list *p;    struct code_block_list *p;
Line 938 
Line 1218 
   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 vm_prims[super2[super_costs[pi-priminfos-DOESJUMP-1].offset]+DOESJUMP+1];        return vm_prims[super2[super_costs[pi-priminfos].offset]];
     /* return pi->start;*/      /* return pi->start;*/
   }    }
   return code;    return code;
Line 949 
Line 1229 
 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];
   
 void set_rel_target(Cell *source, Label target)  static 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)  static 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)  static 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)  static 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 1002 
Line 1281 
   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;
   #else
     compile_prim1(NULL);
 #endif  #endif
   flush_to_here();    flush_to_here();
 }  }
   
 #if 0  #if !(defined(DOUBLY_INDIRECT) || defined(INDIRECT_THREADED))
 /* compile *start into a dynamic superinstruction, updating *start */  #ifdef NO_IP
 void compile_prim_dyn(Cell *start)  static 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(NO_IP)    PrimInfo *pi=&priminfos[p];
   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;  static 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;  
 #elif !defined(NO_DYNAMIC)  
   Label prim=(Label)*start;  
   unsigned i;  
   Address old_code_here;  
   
   i = ((Xt)prim)-vm_prims;  
   prim = *(Xt)prim;  
   if (no_dynamic) {  
     *start = (Cell)prim;  
     return;  
   }  
   if (i>=npriminfos || priminfos[i].start == 0) { /* not a relocatable prim */  
     append_jump();  
     *start = (Cell)prim;  
     return;  
   }  
   assert(priminfos[i].start = prim);  
 #ifdef ALIGN_CODE  
   /*  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  
   *start = (Cell)prim;  
   return;  
 #endif /* !defined(DOUBLY_INDIRECT) */  
 }  
 #endif /* 0 */  
   
 Cell compile_prim_dyn(unsigned p)  
 {  {
   Cell static_prim = (Cell)vm_prims[p+DOESJUMP+1];    Cell static_prim = (Cell)vm_prims[p];
 #if defined(NO_DYNAMIC)  #if defined(NO_DYNAMIC)
   return static_prim;    return static_prim;
 #else /* !defined(NO_DYNAMIC) */  #else /* !defined(NO_DYNAMIC) */
Line 1115 
Line 1365 
   
   if (no_dynamic)    if (no_dynamic)
     return static_prim;      return static_prim;
   p += DOESJUMP+1;    if (p>=npriminfos || !is_relocatable(p)) {
   if (p>=npriminfos || priminfos[p].start == 0) { /* not a relocatable prim */  
     append_jump();      append_jump();
     return static_prim;      return static_prim;
   }    }
   old_code_here = append_prim(p);    old_code_here = append_prim(p);
   last_jump = (priminfos[p].superend) ? 0 : p;    last_jump = p;
     if (priminfos[p].superend)
       append_jump();
   return (Cell)old_code_here;    return (Cell)old_code_here;
 #endif  /* !defined(NO_DYNAMIC) */  #endif  /* !defined(NO_DYNAMIC) */
 }  }
   #endif /* !defined(NO_IP) */
   #endif
   
 #ifndef NO_DYNAMIC  #ifndef NO_DYNAMIC
 int cost_codesize(int prim)  static int cost_codesize(int prim)
 {  {
   return priminfos[prim+DOESJUMP+1].length;    return priminfos[prim].length;
 }  }
 #endif  #endif
   
 int cost_ls(int prim)  static int cost_ls(int prim)
 {  {
   struct cost *c = super_costs+prim;    struct cost *c = super_costs+prim;
   
   return c->loads + c->stores;    return c->loads + c->stores;
 }  }
   
 int cost_lsu(int prim)  static int cost_lsu(int prim)
 {  {
   struct cost *c = super_costs+prim;    struct cost *c = super_costs+prim;
   
   return c->loads + c->stores + c->updates;    return c->loads + c->stores + c->updates;
 }  }
   
 int cost_nexts(int prim)  static int cost_nexts(int prim)
 {  {
   return 1;    return 1;
 }  }
Line 1173 
Line 1426 
   { cost_nexts,    "nexts",    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
   
 #define MAX_BB 128 /* maximum number of instructions in BB */  #define MAX_BB 128 /* maximum number of instructions in BB */
   #define INF_COST 1000000 /* infinite cost */
   #define CANONICAL_STATE 0
   
 /* use dynamic programming to find the shortest paths within the basic  struct waypoint {
    block origs[0..ninsts-1]; optimals[i] contains the superinstruction    int cost;     /* the cost from here to the end */
    on the shortest path to the end of the BB */    PrimNum inst; /* the inst used from here to the next waypoint */
 void optimize_bb(short origs[], short optimals[], int ninsts)    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) */
   };
   
   struct tpa_state { /* tree parsing automaton (like) state */
     /* labeling is back-to-front */
     struct waypoint *inst;  /* in front of instruction */
     struct waypoint *trans; /* in front of instruction and transition */
   };
   
   struct tpa_state *termstate = NULL; /* initialized in loader() */
   
   /* statistics about tree parsing (lazyburg) stuff */
   long lb_basic_blocks = 0;
   long lb_labeler_steps = 0;
   long lb_labeler_automaton = 0;
   long lb_labeler_dynprog = 0;
   long lb_newstate_equiv = 0;
   long lb_newstate_new = 0;
   long lb_applicable_base_rules = 0;
   long lb_applicable_chain_rules = 0;
   
   #if !(defined(DOUBLY_INDIRECT) || defined(INDIRECT_THREADED))
   static void init_waypoints(struct waypoint ws[])
 {  {
   int i,j, mincost;    int k;
   static int costs[MAX_BB+1];  
   
   assert(ninsts<MAX_BB);    for (k=0; k<maxstates; k++)
   costs[ninsts]=0;      ws[k].cost=INF_COST;
   for (i=ninsts-1; i>=0; i--) {  }
     optimals[i] = origs[i];  
     costs[i] = mincost = costs[i+1] + ss_cost(optimals[i]);  static struct tpa_state *empty_tpa_state()
     for (j=2; j<=max_super && i+j<=ninsts ; j++) {  {
       int super, jcost;    struct tpa_state *s = malloc(sizeof(struct tpa_state));
   
       super = lookup_super(origs+i,j);    s->inst  = calloc(maxstates,sizeof(struct waypoint));
       if (super >= 0) {    init_waypoints(s->inst);
         jcost = costs[i+j] + ss_cost(super);    s->trans = calloc(maxstates,sizeof(struct waypoint));
         if (jcost <= mincost) {    /* init_waypoints(s->trans);*/
           optimals[i] = super;    return s;
           mincost = jcost;  
           if (!ss_greedy)  
             costs[i] = jcost;  
         }          }
   
   static void transitions(struct tpa_state *t)
   {
     int k;
     struct super_state *l;
   
     for (k=0; k<maxstates; k++) {
       t->trans[k] = t->inst[k];
       t->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=&(t->trans[c->state_in]);
       struct waypoint *wo=&(t->inst[c->state_out]);
       lb_applicable_chain_rules++;
       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 ? */
     }      }
   }    }
 }  }
   
 /* rewrite the instructions pointed to by instps to use the  static struct tpa_state *make_termstate()
    superinstructions in optimals */  
 void rewrite_bb(Cell *instps[], short *optimals, int ninsts)  
 {  {
   int i,j, nextdyn;    struct tpa_state *s = empty_tpa_state();
   Cell inst;  
     s->inst[CANONICAL_STATE].cost = 0;
     transitions(s);
     return s;
   }
   #endif
   
   #define TPA_SIZE 16384
   
   for (i=0, nextdyn=0; i<ninsts; i++) {  struct tpa_entry {
     if (i==nextdyn) { /* compile dynamically */    struct tpa_entry *next;
       nextdyn += super_costs[optimals[i]].length;    PrimNum inst;
       inst = compile_prim_dyn(optimals[i]);    struct tpa_state *state_behind;  /* note: brack-to-front labeling */
       for (j=0; j<sizeof(cost_sums)/sizeof(cost_sums[0]); j++)    struct tpa_state *state_infront; /* note: brack-to-front labeling */
         cost_sums[j].sum += cost_sums[j].costfunc(optimals[i]);  } *tpa_table[TPA_SIZE];
     } else { /* compile statically */  
       inst = (Cell)vm_prims[optimals[i]+DOESJUMP+1];  #if !(defined(DOUBLY_INDIRECT) || defined(INDIRECT_THREADED))
   static Cell hash_tpa(PrimNum p, struct tpa_state *t)
   {
     UCell it = (UCell )t;
     return (p+it+(it>>14))&(TPA_SIZE-1);
   }
   
   static struct tpa_state **lookup_tpa(PrimNum p, struct tpa_state *t2)
   {
     int hash=hash_tpa(p, t2);
     struct tpa_entry *te = tpa_table[hash];
   
     if (tpa_noautomaton) {
       static struct tpa_state *t;
       t = NULL;
       return &t;
     }
     for (; te!=NULL; te = te->next) {
       if (p == te->inst && t2 == te->state_behind)
         return &(te->state_infront);
     }
     te = (struct tpa_entry *)malloc(sizeof(struct tpa_entry));
     te->next = tpa_table[hash];
     te->inst = p;
     te->state_behind = t2;
     te->state_infront = NULL;
     tpa_table[hash] = te;
     return &(te->state_infront);
   }
   
   static void tpa_state_normalize(struct tpa_state *t)
   {
     /* normalize so cost of canonical state=0; this may result in
        negative states for some states */
     int d = t->inst[CANONICAL_STATE].cost;
     int i;
   
     for (i=0; i<maxstates; i++) {
       if (t->inst[i].cost != INF_COST)
         t->inst[i].cost -= d;
       if (t->trans[i].cost != INF_COST)
         t->trans[i].cost -= d;
     }
   }
   
   static int tpa_state_equivalent(struct tpa_state *t1, struct tpa_state *t2)
   {
     return (memcmp(t1->inst, t2->inst, maxstates*sizeof(struct waypoint)) == 0 &&
             memcmp(t1->trans,t2->trans,maxstates*sizeof(struct waypoint)) == 0);
   }
   #endif
   
   struct tpa_state_entry {
     struct tpa_state_entry *next;
     struct tpa_state *state;
   } *tpa_state_table[TPA_SIZE];
   
   #if !(defined(DOUBLY_INDIRECT) || defined(INDIRECT_THREADED))
   static Cell hash_tpa_state(struct tpa_state *t)
   {
     int *ti = (int *)(t->inst);
     int *tt = (int *)(t->trans);
     int r=0;
     int i;
   
     for (i=0; ti+i < (int *)(t->inst+maxstates); i++)
       r += ti[i]+tt[i];
     return (r+(r>>14)+(r>>22)) & (TPA_SIZE-1);
   }
   
   static struct tpa_state *lookup_tpa_state(struct tpa_state *t)
   {
     Cell hash = hash_tpa_state(t);
     struct tpa_state_entry *te = tpa_state_table[hash];
     struct tpa_state_entry *tn;
   
     if (!tpa_noequiv) {
       for (; te!=NULL; te = te->next) {
         if (tpa_state_equivalent(t, te->state)) {
           lb_newstate_equiv++;
           free(t->inst);
           free(t->trans);
           free(t);
           return te->state;
         }
       }
       tn = (struct tpa_state_entry *)malloc(sizeof(struct tpa_state_entry));
       tn->next = te;
       tn->state = t;
       tpa_state_table[hash] = tn;
     }
     lb_newstate_new++;
     if (tpa_trace)
       fprintf(stderr, "%ld %ld lb_states\n", lb_labeler_steps, lb_newstate_new);
     return t;
   }
   
   /* 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 */
   static void optimize_rewrite(Cell *instps[], PrimNum origs[], int ninsts)
   {
     int i,j;
     struct tpa_state *ts[ninsts+1];
     int nextdyn, nextstate, no_transition;
   
     lb_basic_blocks++;
     ts[ninsts] = termstate;
   #ifndef NO_DYNAMIC
     if (print_sequences) {
       for (i=0; i<ninsts; i++)
   #if defined(BURG_FORMAT)
         fprintf(stderr, "op%d ", super_costs[origs[i]].offset);
   #else
         fprintf(stderr, "%s ", prim_names[origs[i]]);
   #endif
       fprintf(stderr, "\n");
     }
   #endif
     for (i=ninsts-1; i>=0; i--) {
       struct tpa_state **tp = lookup_tpa(origs[i],ts[i+1]);
       struct tpa_state *t = *tp;
       lb_labeler_steps++;
       if (t) {
         ts[i] = t;
         lb_labeler_automaton++;
       }
       else {
         lb_labeler_dynprog++;
         ts[i] = empty_tpa_state();
         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=&(ts[i]->inst[c->state_in]);
               struct waypoint *wo=&(ts[i+j]->trans[c->state_out]);
               int no_transition = wo->no_transition;
               lb_applicable_base_rules++;
               if (!(is_relocatable(s)) && !wo->relocatable) {
                 wo=&(ts[i+j]->inst[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(ts[i]);
         tpa_state_normalize(ts[i]);
         *tp = ts[i] = lookup_tpa_state(ts[i]);
         if (tpa_trace)
           fprintf(stderr, "%ld %ld lb_table_entries\n", lb_labeler_steps, lb_labeler_dynprog);
       }
     }
     /* now rewrite the instructions */
     nextdyn=0;
     nextstate=CANONICAL_STATE;
     no_transition = ((!ts[0]->trans[nextstate].relocatable)
                      ||ts[0]->trans[nextstate].no_transition);
     for (i=0; i<ninsts; i++) {
       Cell tc=0, tc2;
       if (i==nextdyn) {
         if (!no_transition) {
           /* process trans */
           PrimNum p = ts[i]->trans[nextstate].inst;
           struct cost *c = super_costs+p;
           assert(ts[i]->trans[nextstate].cost != INF_COST);
           assert(c->state_in==nextstate);
           tc = compile_prim_dyn(p,NULL);
           nextstate = c->state_out;
         }
         {
           /* process inst */
           PrimNum p = ts[i]->inst[nextstate].inst;
           struct cost *c=super_costs+p;
           assert(c->state_in==nextstate);
           assert(ts[i]->inst[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 = ts[i]->inst[nextstate].no_transition;
           nextstate = c->state_out;
           nextdyn += c->length;
         }
       } else {
   #if defined(GFORTH_DEBUGGING)
         assert(0);
   #endif
         tc=0;
         /* tc= (Cell)vm_prims[ts[i]->inst[CANONICAL_STATE].inst]; */
     }      }
     *(instps[i]) = inst;      *(instps[i]) = tc;
   }    }
     if (!no_transition) {
       PrimNum p = ts[i]->trans[nextstate].inst;
       struct cost *c = super_costs+p;
       assert(c->state_in==nextstate);
       assert(ts[i]->trans[nextstate].cost != INF_COST);
       assert(i==nextdyn);
       (void)compile_prim_dyn(p,NULL);
       nextstate = c->state_out;
 }  }
     assert(nextstate==CANONICAL_STATE);
   }
   #endif
   
 /* compile *start, possibly rewriting it into a static and/or dynamic  /* compile *start, possibly rewriting it into a static and/or dynamic
    superinstruction */     superinstruction */
 void compile_prim1(Cell *start)  void compile_prim1(Cell *start)
 {  {
 #if defined(DOUBLY_INDIRECT)  #if defined(DOUBLY_INDIRECT)
   Label prim=(Label)*start;    Label prim;
   
     if (start==NULL)
       return;
     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);
     *start=(Cell)prim;      *start=(Cell)prim;
Line 1242 
Line 1778 
 #elif defined(INDIRECT_THREADED)  #elif defined(INDIRECT_THREADED)
   return;    return;
 #else /* !(defined(DOUBLY_INDIRECT) || defined(INDIRECT_THREADED)) */  #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 Cell *instps[MAX_BB];
   static short origs[MAX_BB];    static PrimNum origs[MAX_BB];
   static short optimals[MAX_BB];  
   static int ninsts=0;    static int ninsts=0;
   unsigned prim_num;    PrimNum prim_num;
   
   if (start==NULL)    if (start==NULL || ninsts >= MAX_BB ||
     goto end_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) {
         align_code();
         return;
       }
     }
   prim_num = ((Xt)*start)-vm_prims;    prim_num = ((Xt)*start)-vm_prims;
   if (prim_num >= npriminfos)    if(prim_num >= npriminfos) {
     goto end_bb;      optimize_rewrite(instps,origs,ninsts);
       /* fprintf(stderr,"optimize_rewrite(...,%d)\n",ninsts);*/
       ninsts=0;
       return;
     }
   assert(ninsts<MAX_BB);    assert(ninsts<MAX_BB);
   instps[ninsts] = start;    instps[ninsts] = start;
   origs[ninsts] = prim_num-DOESJUMP-1;    origs[ninsts] = prim_num;
   ninsts++;    ninsts++;
   if (ninsts >= MAX_BB || superend[prim_num-DOESJUMP-1]) {  
   end_bb:  
     optimize_bb(origs,optimals,ninsts);  
     rewrite_bb(instps,optimals,ninsts);  
     ninsts=0;  
   }  
 #endif /* !(defined(DOUBLY_INDIRECT) || defined(INDIRECT_THREADED)) */  #endif /* !(defined(DOUBLY_INDIRECT) || defined(INDIRECT_THREADED)) */
 }  }
   
 #if defined(PRINT_SUPER_LENGTHS) && !defined(NO_DYNAMIC)  #ifndef STANDALONE
 Cell prim_length(Cell prim)  Address gforth_loader(FILE *imagefile, char* filename)
 {  
   return priminfos[prim+DOESJUMP+1].length;  
 }  
 #endif  
   
 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) */
 {  {
   ImageHeader header;    ImageHeader header;
Line 1301 
Line 1840 
 #endif  #endif
     ;      ;
   
   vm_prims = engine(0,0,0,0,0);    vm_prims = gforth_engine(0,0,0,0,0 sr_call);
   check_prims(vm_prims);    check_prims(vm_prims);
   prepare_super_table();    prepare_super_table();
 #ifndef DOUBLY_INDIRECT  #ifndef DOUBLY_INDIRECT
Line 1312 
Line 1851 
 #else /* defined(DOUBLY_INDIRECT) */  #else /* defined(DOUBLY_INDIRECT) */
   check_sum = (UCell)vm_prims;    check_sum = (UCell)vm_prims;
 #endif /* defined(DOUBLY_INDIRECT) */  #endif /* defined(DOUBLY_INDIRECT) */
   #if !(defined(DOUBLY_INDIRECT) || defined(INDIRECT_THREADED))
     termstate = make_termstate();
   #endif /* !(defined(DOUBLY_INDIRECT) || defined(INDIRECT_THREADED)) */
   
   do {    do {
     if(fread(magic,sizeof(Char),8,imagefile) < 8) {      if(fread(magic,sizeof(Char),8,imagefile) < 8) {
Line 1348 
Line 1890 
 #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);
   imp=image+preamblesize;    imp=image+preamblesize;
   
   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  == (Address)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, (Cell)header.base, vm_prims);      gforth_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 1393 
Line 1935 
   
   return imp;    return imp;
 }  }
   #endif
   
 /* pointer to last '/' or '\' in file, 0 if there is none. */  /* pointer to last '/' or '\' in file, 0 if there is none. */
 char *onlypath(char *filename)  static char *onlypath(char *filename)
 {  {
   return strrchr(filename, DIRSEP);    return strrchr(filename, DIRSEP);
 }  }
   
 FILE *openimage(char *fullfilename)  static FILE *openimage(char *fullfilename)
 {  {
   FILE *image_file;    FILE *image_file;
   char * expfilename = tilde_cstr(fullfilename, strlen(fullfilename), 1);    char * expfilename = tilde_cstr((Char *)fullfilename, strlen(fullfilename), 1);
   
   image_file=fopen(expfilename,"rb");    image_file=fopen(expfilename,"rb");
   if (image_file!=NULL && debug)    if (image_file!=NULL && debug)
Line 1412 
Line 1955 
 }  }
   
 /* try to open image file concat(path[0:len],imagename) */  /* try to open image file concat(path[0:len],imagename) */
 FILE *checkimage(char *path, int len, char *imagename)  static FILE *checkimage(char *path, int len, char *imagename)
 {  {
   int dirlen=len;    int dirlen=len;
   char fullfilename[dirlen+strlen(imagename)+2];    char fullfilename[dirlen+strlen((char *)imagename)+2];
   
   memcpy(fullfilename, path, dirlen);    memcpy(fullfilename, path, dirlen);
   if (fullfilename[dirlen-1]!=DIRSEP)    if (fullfilename[dirlen-1]!=DIRSEP)
Line 1424 
Line 1967 
   return openimage(fullfilename);    return openimage(fullfilename);
 }  }
   
 FILE * open_image_file(char * imagename, char * path)  static FILE * open_image_file(char * imagename, char * path)
 {  {
   FILE * image_file=NULL;    FILE * image_file=NULL;
   char *origpath=path;    char *origpath=path;
Line 1456 
Line 1999 
 }  }
 #endif  #endif
   
   #ifdef STANDALONE_ALLOC
   Address gforth_alloc(Cell size)
   {
     Address r;
     /* leave a little room (64B) for stack underflows */
     if ((r = malloc(size+64))==NULL) {
       perror(progname);
       exit(1);
     }
     r = (Address)((((Cell)r)+(sizeof(Float)-1))&(-sizeof(Float)));
     debugp(stderr, "malloc succeeds, address=$%lx\n", (long)r);
     return r;
   }
   #endif
   
 #ifdef HAS_OS  #ifdef HAS_OS
 UCell convsize(char *s, UCell elemsize)  static UCell convsize(char *s, UCell elemsize)
 /* converts s of the format [0-9]+[bekMGT]? (e.g. 25k) into the number  /* converts s of the format [0-9]+[bekMGT]? (e.g. 25k) into the number
    of bytes.  the letter at the end indicates the unit, where e stands     of bytes.  the letter at the end indicates the unit, where e stands
    for the element size. default is e */     for the element size. default is e */
Line 1493 
Line 2051 
   
 enum {  enum {
   ss_number = 256,    ss_number = 256,
     ss_states,
   ss_min_codesize,    ss_min_codesize,
   ss_min_ls,    ss_min_ls,
   ss_min_lsu,    ss_min_lsu,
   ss_min_nexts,    ss_min_nexts,
 };  };
   
   #ifndef STANDALONE
 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 1514 
Line 2074 
       {"return-stack-size", required_argument, NULL, 'r'},        {"return-stack-size", required_argument, NULL, 'r'},
       {"fp-stack-size", required_argument, NULL, 'f'},        {"fp-stack-size", required_argument, NULL, 'f'},
       {"locals-stack-size", required_argument, NULL, 'l'},        {"locals-stack-size", required_argument, NULL, 'l'},
         {"vm-commit", no_argument, &map_noreserve, 0},
       {"path", required_argument, NULL, 'p'},        {"path", required_argument, NULL, 'p'},
       {"version", no_argument, NULL, 'v'},        {"version", no_argument, NULL, 'v'},
       {"help", no_argument, NULL, 'h'},        {"help", no_argument, NULL, 'h'},
Line 1521 
Line 2082 
       {"offset-image", no_argument, &offset_image, 1},        {"offset-image", no_argument, &offset_image, 1},
       {"no-offset-im", no_argument, &offset_image, 0},        {"no-offset-im", no_argument, &offset_image, 0},
       {"clear-dictionary", no_argument, &clear_dictionary, 1},        {"clear-dictionary", no_argument, &clear_dictionary, 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},
         {"die-on-signal", no_argument, &die_on_signal, 1},
         {"ignore-async-signals", no_argument, &ignore_async_signals, 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},        {"print-metrics", no_argument, &print_metrics, 1},
         {"print-sequences", no_argument, &print_sequences, 1},
       {"ss-number", required_argument, NULL, ss_number},        {"ss-number", required_argument, NULL, ss_number},
         {"ss-states", required_argument, NULL, ss_states},
 #ifndef NO_DYNAMIC  #ifndef NO_DYNAMIC
       {"ss-min-codesize", no_argument, NULL, ss_min_codesize},        {"ss-min-codesize", no_argument, NULL, ss_min_codesize},
 #endif  #endif
Line 1535 
Line 2100 
       {"ss-min-lsu",      no_argument, NULL, ss_min_lsu},        {"ss-min-lsu",      no_argument, NULL, ss_min_lsu},
       {"ss-min-nexts",    no_argument, NULL, ss_min_nexts},        {"ss-min-nexts",    no_argument, NULL, ss_min_nexts},
       {"ss-greedy",       no_argument, &ss_greedy, 1},        {"ss-greedy",       no_argument, &ss_greedy, 1},
         {"tpa-noequiv",     no_argument, &tpa_noequiv, 1},
         {"tpa-noautomaton", no_argument, &tpa_noautomaton, 1},
         {"tpa-trace",       no_argument, &tpa_trace, 1},
       {0,0,0,0}        {0,0,0,0}
       /* no-init-file, no-rc? */        /* no-init-file, no-rc? */
     };      };
Line 1559 
Line 2127 
     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_number: static_super_number = atoi(optarg); break;
       case ss_states: maxstates = max(min(atoi(optarg),MAX_STATE),1); break;
 #ifndef NO_DYNAMIC  #ifndef NO_DYNAMIC
     case ss_min_codesize: ss_cost = cost_codesize; break;      case ss_min_codesize: ss_cost = cost_codesize; break;
 #endif  #endif
Line 1568 
Line 2137 
     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\
   --appl-image FILE                 equivalent to '--image-file=FILE --'\n\    --appl-image FILE                 Equivalent to '--image-file=FILE --'\n\
   --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\
   --die-on-signal                   exit instead of CATCHing some signals\n\    --diag                            Print diagnostic information during startup\n\
   --dynamic                         use dynamic native code\n\    --die-on-signal                   Exit instead of THROWing some signals\n\
     --dynamic                         Use dynamic native code\n\
   -f SIZE, --fp-stack-size=SIZE     Specify floating point stack size\n\    -f SIZE, --fp-stack-size=SIZE     Specify floating point stack size\n\
   -h, --help                        Print this message and exit\n\    -h, --help                        Print this message and exit\n\
     --ignore-async-signals            Ignore instead of THROWing async. signals\n\
   -i FILE, --image-file=FILE        Use image FILE instead of `gforth.fi'\n\    -i FILE, --image-file=FILE        Use image FILE instead of `gforth.fi'\n\
   -l SIZE, --locals-stack-size=SIZE Specify locals stack size\n\    -l SIZE, --locals-stack-size=SIZE Specify locals stack size\n\
   -m SIZE, --dictionary-size=SIZE   Specify Forth dictionary size\n\    -m SIZE, --dictionary-size=SIZE   Specify Forth dictionary size\n\
Line 1585 
Line 2156 
   --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\    --print-metrics                   Print some code generation metrics on exit\n\
     --print-sequences                 Print primitive sequences for optimization\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-greedy                       Greedy, not optimal superinst selection\n\
   --ss-min-codesize                 select superinsts for smallest native code\n\    --ss-min-codesize                 Select superinsts for smallest native code\n\
   --ss-min-ls                       minimize loads and stores\n\    --ss-min-ls                       Minimize loads and stores\n\
   --ss-min-lsu                      minimize loads, stores, and pointer updates\n\    --ss-min-lsu                      Minimize loads, stores, and pointer updates\n\
   --ss-min-nexts                    minimize the number of static superinsts\n\    --ss-min-nexts                    Minimize the number of static superinsts\n\
   --ss-number=N                     use N static superinsts (default max)\n\    --ss-number=N                     Use N static superinsts (default max)\n\
     --ss-states=N                     N states for stack caching (default max)\n\
     --tpa-noequiv                     Automaton without state equivalence\n\
     --tpa-noautomaton                 Dynamic programming only\n\
     --tpa-trace                       Report new states etc.\n\
   -v, --version                     Print engine version and exit\n\    -v, --version                     Print engine version and exit\n\
     --vm-commit                       Use OS default for memory overcommit\n\
 SIZE arguments consist of an integer followed by a unit. The unit can be\n\  SIZE arguments consist of an integer followed by a unit. The unit can be\n\
   `b' (byte), `e' (element; default), `k' (KB), `M' (MB), `G' (GB) or `T' (TB).\n",    `b' (byte), `e' (element; default), `k' (KB), `M' (MB), `G' (GB) or `T' (TB).\n",
               argv[0]);                argv[0]);
Line 1602 
Line 2179 
   }    }
 }  }
 #endif  #endif
   #endif
   
 #ifdef INCLUDE_IMAGE  static void print_diag()
 extern Cell image[];  {
 extern const char reloc_bits[];  
   #if !defined(HAVE_GETRUSAGE)
     fprintf(stderr, "*** missing functionality ***\n"
   #ifndef HAVE_GETRUSAGE
             "    no getrusage -> CPUTIME broken\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
        0
   #endif
        )
       debugp(stderr, "relocs: %d:%d\n", relocs, nonrelocs);
       fprintf(stderr, "*** %sperformance 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) || !(defined(FORCE_REG) || defined(FORCE_REG_UNNECESSARY)) || defined(BUGGY_LONG_LONG)
               "",
   #else
               "no ",
   #endif
   #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
   #ifdef BUGGY_LL_SHIFT
               "SHIFT, "
   #endif
   #ifdef BUGGY_LL_D2F
               "D2F, "
   #endif
   #ifdef BUGGY_LL_F2D
               "F2D, "
   #endif
               "\b\b slow\n"
   #endif
   #if !(defined(FORCE_REG) || defined(FORCE_REG_UNNECESSARY))
               "    automatic register allocation: performance degradation possible\n"
   #endif
               "",
               (relocs < nonrelocs) ? "    gcc PR 15242 -> no dynamic code generation (use gcc-2.95 instead)\n" : "");
   }
   
   #ifdef STANDALONE
   Cell data_abort_pc;
   
   void data_abort_C(void)
   {
     while(1) {
     }
   }
 #endif  #endif
   
 int main(int argc, char **argv, char **env)  int main(int argc, char **argv, char **env)
Line 1622 
Line 2261 
 #endif  #endif
   int retvalue;    int retvalue;
   
 #if defined(i386) && defined(ALIGNMENT_CHECK)  #ifndef STANDALONE
   /* turn on alignment checks on the 486.  
    * on the 386 this should have no effect. */  
   __asm__("pushfl; popl %eax; orl $0x40000, %eax; pushl %eax; popfl;");  
   /* this is unusable with Linux' libc.4.6.27, because this library is  
      not alignment-clean; we would have to replace some library  
      functions (e.g., memcpy) to make it work. Also GCC doesn't try to keep  
      the stack FP-aligned. */  
 #endif  
   
   /* buffering of the user output device */    /* buffering of the user output device */
 #ifdef _IONBF  #ifdef _IONBF
   if (isatty(fileno(stdout))) {    if (isatty(fileno(stdout))) {
Line 1639 
Line 2269 
     setvbuf(stdout,NULL,_IONBF,0);      setvbuf(stdout,NULL,_IONBF,0);
   }    }
 #endif  #endif
   #else
     prep_terminal();
   #endif
   
   progname = argv[0];    progname = argv[0];
   
   #ifndef STANDALONE
     if (lt_dlinit()!=0) {
       fprintf(stderr,"%s: lt_dlinit failed", progname);
       exit(1);
     }
   
 #ifdef HAS_OS  #ifdef HAS_OS
   gforth_args(argc, argv, &path, &imagename);    gforth_args(argc, argv, &path, &imagename);
 #ifndef NO_DYNAMIC  #ifndef NO_DYNAMIC
   if (no_dynamic && ss_cost == cost_codesize) {    init_ss_cost();
     ss_cost = cost_lsu;  
     cost_sums[0] = cost_sums[1];  
     if (debug)  
       fprintf(stderr, "--no-dynamic conflicts with --ss-min-codesize, reverting to --ss-min-lsu\n");  
   }  
 #endif /* !defined(NO_DYNAMIC) */  #endif /* !defined(NO_DYNAMIC) */
 #endif /* defined(HAS_OS) */  #endif /* defined(HAS_OS) */
   #endif
   
 #ifdef INCLUDE_IMAGE  #ifdef STANDALONE
   set_stack_sizes((ImageHeader *)image);    image = gforth_engine(0, 0, 0, 0, 0 sr_call);
   if(((ImageHeader *)image)->base != image)  
     relocate(image, reloc_bits, ((ImageHeader *)image)->image_size,  
              (Label*)engine(0, 0, 0, 0, 0));  
   alloc_stacks((ImageHeader *)image);    alloc_stacks((ImageHeader *)image);
 #else  #else
   image_file = open_image_file(imagename, path);    image_file = open_image_file(imagename, path);
   image = loader(image_file, imagename);    image = gforth_loader(image_file, imagename);
 #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 1686 
Line 2320 
       else        else
         *p2 = *p1;          *p2 = *p1;
     *p2='\0';      *p2='\0';
     retvalue = go_forth(image, 4, environ);      retvalue = gforth_go(image, 4, environ);
 #ifdef SIGPIPE  #if defined(SIGPIPE) && !defined(STANDALONE)
     bsd_signal(SIGPIPE, SIG_IGN);      bsd_signal(SIGPIPE, SIG_IGN);
 #endif  #endif
 #ifdef VM_PROFILING  #ifdef VM_PROFILING
     vm_print_profile(stderr);      vm_print_profile(stderr);
 #endif  #endif
     deprep_terminal();      deprep_terminal();
   #ifndef STANDALONE
       if (lt_dlexit()!=0)
         fprintf(stderr,"%s: lt_dlexit failed", progname);
   #endif
   }    }
   if (print_metrics) {    if (print_metrics) {
     int i;      int i;
     fprintf(stderr, "code size = %8ld\n", dyncodesize());      fprintf(stderr, "code size = %8ld\n", dyncodesize());
   #ifndef STANDALONE
     for (i=0; i<sizeof(cost_sums)/sizeof(cost_sums[0]); i++)      for (i=0; i<sizeof(cost_sums)/sizeof(cost_sums[0]); i++)
       fprintf(stderr, "metric %8s: %8ld\n",        fprintf(stderr, "metric %8s: %8ld\n",
               cost_sums[i].metricname, cost_sums[i].sum);                cost_sums[i].metricname, cost_sums[i].sum);
   #endif
       fprintf(stderr,"lb_basic_blocks = %ld\n", lb_basic_blocks);
       fprintf(stderr,"lb_labeler_steps = %ld\n", lb_labeler_steps);
       fprintf(stderr,"lb_labeler_automaton = %ld\n", lb_labeler_automaton);
       fprintf(stderr,"lb_labeler_dynprog = %ld\n", lb_labeler_dynprog);
       fprintf(stderr,"lb_newstate_equiv = %ld\n", lb_newstate_equiv);
       fprintf(stderr,"lb_newstate_new = %ld\n", lb_newstate_new);
       fprintf(stderr,"lb_applicable_base_rules = %ld\n", lb_applicable_base_rules);
       fprintf(stderr,"lb_applicable_chain_rules = %ld\n", lb_applicable_chain_rules);
     }
     if (tpa_trace) {
       fprintf(stderr, "%ld %ld lb_states\n", lb_labeler_steps, lb_newstate_new);
       fprintf(stderr, "%ld %ld lb_table_entries\n", lb_labeler_steps, lb_labeler_dynprog);
   }    }
   return retvalue;    return retvalue;
 }  }

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help